aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorLars Magne Ingebrigtsen1999-02-20 14:05:57 +0000
committerLars Magne Ingebrigtsen1999-02-20 14:05:57 +0000
commit6748645fc3dd1604ed57a883b7c346128af27d90 (patch)
treec4c528db7873d3ef96121c002b4d09209c305dca
parent44a6ed57c9af413959fdebe38649c0df4a055fca (diff)
downloademacs-6748645fc3dd1604ed57a883b7c346128af27d90.tar.gz
emacs-6748645fc3dd1604ed57a883b7c346128af27d90.zip
Upgrading to Gnus 5.7; see ChangeLog
-rw-r--r--lisp/gnus/gnus-art.el704
-rw-r--r--lisp/gnus/gnus-async.el30
-rw-r--r--lisp/gnus/gnus-audio.el13
-rw-r--r--lisp/gnus/gnus-bcklg.el12
-rw-r--r--lisp/gnus/gnus-cache.el84
-rw-r--r--lisp/gnus/gnus-cite.el152
-rw-r--r--lisp/gnus/gnus-cus.el26
-rw-r--r--lisp/gnus/gnus-demon.el48
-rw-r--r--lisp/gnus/gnus-dup.el8
-rw-r--r--lisp/gnus/gnus-eform.el13
-rw-r--r--lisp/gnus/gnus-ems.el88
-rw-r--r--lisp/gnus/gnus-gl.el25
-rw-r--r--lisp/gnus/gnus-group.el254
-rw-r--r--lisp/gnus/gnus-int.el397
-rw-r--r--lisp/gnus/gnus-kill.el35
-rw-r--r--lisp/gnus/gnus-logic.el12
-rw-r--r--lisp/gnus/gnus-mh.el6
-rw-r--r--lisp/gnus/gnus-move.el35
-rw-r--r--lisp/gnus/gnus-msg.el345
-rw-r--r--lisp/gnus/gnus-mule.el17
-rw-r--r--lisp/gnus/gnus-nocem.el59
-rw-r--r--lisp/gnus/gnus-range.el8
-rw-r--r--lisp/gnus/gnus-salt.el205
-rw-r--r--lisp/gnus/gnus-score.el572
-rw-r--r--lisp/gnus/gnus-soup.el54
-rw-r--r--lisp/gnus/gnus-spec.el46
-rw-r--r--lisp/gnus/gnus-srvr.el179
-rw-r--r--lisp/gnus/gnus-start.el229
-rw-r--r--lisp/gnus/gnus-sum.el2324
-rw-r--r--lisp/gnus/gnus-topic.el255
-rw-r--r--lisp/gnus/gnus-undo.el37
-rw-r--r--lisp/gnus/gnus-util.el280
-rw-r--r--lisp/gnus/gnus-uu.el418
-rw-r--r--lisp/gnus/gnus-vm.el12
-rw-r--r--lisp/gnus/gnus-win.el108
-rw-r--r--lisp/gnus/gnus.el472
-rw-r--r--lisp/gnus/message.el732
-rw-r--r--lisp/gnus/messcompat.el17
-rw-r--r--lisp/gnus/nnbabyl.el12
-rw-r--r--lisp/gnus/nndir.el10
-rw-r--r--lisp/gnus/nndoc.el195
-rw-r--r--lisp/gnus/nndraft.el211
-rw-r--r--lisp/gnus/nneething.el23
-rw-r--r--lisp/gnus/nnfolder.el280
-rw-r--r--lisp/gnus/nngateway.el14
-rw-r--r--lisp/gnus/nnheader.el90
-rw-r--r--lisp/gnus/nnkiboze.el54
-rw-r--r--lisp/gnus/nnmail.el373
-rw-r--r--lisp/gnus/nnmbox.el17
-rw-r--r--lisp/gnus/nnmh.el112
-rw-r--r--lisp/gnus/nnml.el95
-rw-r--r--lisp/gnus/nnoo.el56
-rw-r--r--lisp/gnus/nnsoup.el34
-rw-r--r--lisp/gnus/nnspool.el19
-rw-r--r--lisp/gnus/nntp.el443
-rw-r--r--lisp/gnus/nnvirtual.el76
-rw-r--r--lisp/gnus/nnweb.el87
-rw-r--r--lisp/gnus/pop3.el60
-rw-r--r--lisp/gnus/score-mode.el13
59 files changed, 6450 insertions, 4135 deletions
diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el
index c0ce2c5be9f..c777830a5a2 100644
--- a/lisp/gnus/gnus-art.el
+++ b/lisp/gnus/gnus-art.el
@@ -1,7 +1,7 @@
1;;; gnus-art.el --- article mode commands for Gnus 1;;; gnus-art.el --- article mode commands for Gnus
2;; Copyright (C) 1996,97 Free Software Foundation, Inc. 2;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: news 5;; Keywords: news
6 6
7;; This file is part of GNU Emacs. 7;; This file is part of GNU Emacs.
@@ -27,6 +27,8 @@
27 27
28(eval-when-compile (require 'cl)) 28(eval-when-compile (require 'cl))
29 29
30(eval-when-compile (require 'cl))
31
30(require 'custom) 32(require 'custom)
31(require 'gnus) 33(require 'gnus)
32(require 'gnus-sum) 34(require 'gnus-sum)
@@ -91,11 +93,26 @@
91 :group 'gnus-article) 93 :group 'gnus-article)
92 94
93(defcustom gnus-ignored-headers 95(defcustom gnus-ignored-headers
94 '("^Path:" "^Posting-Version:" "^Article-I.D.:" "^Expires:" 96 '("^Path:" "^Expires:" "^Date-Received:" "^References:" "^Xref:" "^Lines:"
95 "^Date-Received:" "^References:" "^Control:" "^Xref:" "^Lines:" 97 "^Relay-Version:" "^Message-ID:" "^Approved:" "^Sender:" "^Received:"
96 "^Posted:" "^Relay-Version:" "^Message-ID:" "^Nf-ID:" "^Nf-From:" 98 "^X-UIDL:" "^MIME-Version:" "^Return-Path:" "^In-Reply-To:"
97 "^Approved:" "^Sender:" "^Received:" "^Mail-from:") 99 "^Content-Type:" "^Content-Transfer-Encoding:" "^X-WebTV-Signature:"
98 "All headers that match this regexp will be hidden. 100 "^X-MimeOLE:" "^X-MSMail-Priority:" "^X-Priority:" "^X-Loop:"
101 "^X-Authentication-Warning:" "^X-MIME-Autoconverted:" "^X-Face:"
102 "^X-Attribution:" "^X-Originating-IP:" "^Delivered-To:"
103 "^NNTP-[-A-Za-z]+:" "^Distribution:" "^X-no-archive:" "^X-Trace:"
104 "^X-Complaints-To:" "^X-NNTP-Posting-Host:" "^X-Orig.*:"
105 "^Abuse-Reports-To:" "^Cache-Post-Path:" "^X-Article-Creation-Date:"
106 "^X-Poster:" "^X-Mail2News-Path:" "^X-Server-Date:" "^X-Cache:"
107 "^Originator:" "^X-Problems-To:" "^X-Auth-User:" "^X-Post-Time:"
108 "^X-Admin:" "^X-UID:" "^Resent-[-A-Za-z]+:" "^X-Mailing-List:"
109 "^Precedence:" "^Original-[-A-Za-z]+:" "^X-filename:" "^X-Orcpt:"
110 "^Old-Received:" "^X-Pgp-Fingerprint:" "^X-Pgp-Key-Id:"
111 "^X-Pgp-Public-Key-Url:" "^X-Auth:" "^X-From-Line:"
112 "^X-Gnus-Article-Number:" "^X-Majordomo:" "^X-Url:" "^X-Sender:"
113 "^X-Mailing-List:" "^MBOX-Line" "^Priority:" "^X-Pgp" "^X400-[-A-Za-z]+:"
114 "^Status:")
115 "*All headers that start with this regexp will be hidden.
99This variable can also be a list of regexps of headers to be ignored. 116This variable can also be a list of regexps of headers to be ignored.
100If `gnus-visible-headers' is non-nil, this variable will be ignored." 117If `gnus-visible-headers' is non-nil, this variable will be ignored."
101 :type '(choice :custom-show nil 118 :type '(choice :custom-show nil
@@ -104,8 +121,8 @@ If `gnus-visible-headers' is non-nil, this variable will be ignored."
104 :group 'gnus-article-hiding) 121 :group 'gnus-article-hiding)
105 122
106(defcustom gnus-visible-headers 123(defcustom gnus-visible-headers
107 "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From" 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:"
108 "All headers that do not match this regexp will be hidden. 125 "*All headers that do not match this regexp will be hidden.
109This variable can also be a list of regexp of headers to remain visible. 126This variable can also be a list of regexp of headers to remain visible.
110If this variable is non-nil, `gnus-ignored-headers' will be ignored." 127If this variable is non-nil, `gnus-ignored-headers' will be ignored."
111 :type '(repeat :value-to-internal (lambda (widget value) 128 :type '(repeat :value-to-internal (lambda (widget value)
@@ -119,7 +136,7 @@ If this variable is non-nil, `gnus-ignored-headers' will be ignored."
119(defcustom gnus-sorted-header-list 136(defcustom gnus-sorted-header-list
120 '("^From:" "^Subject:" "^Summary:" "^Keywords:" "^Newsgroups:" 137 '("^From:" "^Subject:" "^Summary:" "^Keywords:" "^Newsgroups:"
121 "^Followup-To:" "^To:" "^Cc:" "^Date:" "^Organization:") 138 "^Followup-To:" "^To:" "^Cc:" "^Date:" "^Organization:")
122 "This variable is a list of regular expressions. 139 "*This variable is a list of regular expressions.
123If it is non-nil, headers that match the regular expressions will 140If it is non-nil, headers that match the regular expressions will
124be placed first in the article buffer in the sequence specified by 141be placed first in the article buffer in the sequence specified by
125this list." 142this list."
@@ -129,12 +146,14 @@ this list."
129(defcustom gnus-boring-article-headers '(empty followup-to reply-to) 146(defcustom gnus-boring-article-headers '(empty followup-to reply-to)
130 "Headers that are only to be displayed if they have interesting data. 147 "Headers that are only to be displayed if they have interesting data.
131Possible values in this list are `empty', `newsgroups', `followup-to', 148Possible values in this list are `empty', `newsgroups', `followup-to',
132`reply-to', and `date'." 149`reply-to', `date', `long-to', and `many-to'."
133 :type '(set (const :tag "Headers with no content." empty) 150 :type '(set (const :tag "Headers with no content." empty)
134 (const :tag "Newsgroups with only one group." newsgroups) 151 (const :tag "Newsgroups with only one group." newsgroups)
135 (const :tag "Followup-to identical to newsgroups." followup-to) 152 (const :tag "Followup-to identical to newsgroups." followup-to)
136 (const :tag "Reply-to identical to from." reply-to) 153 (const :tag "Reply-to identical to from." reply-to)
137 (const :tag "Date less than four days old." date)) 154 (const :tag "Date less than four days old." date)
155 (const :tag "Very long To header." long-to)
156 (const :tag "Multiple To headers." many-to))
138 :group 'gnus-article-hiding) 157 :group 'gnus-article-hiding)
139 158
140(defcustom gnus-signature-separator '("^-- $" "^-- *$") 159(defcustom gnus-signature-separator '("^-- $" "^-- *$")
@@ -153,7 +172,10 @@ longer (in lines) than that number. If it is a function, the function
153will be called without any parameters, and if it returns nil, there is 172will be called without any parameters, and if it returns nil, there is
154no signature in the buffer. If it is a string, it will be used as a 173no signature in the buffer. If it is a string, it will be used as a
155regexp. If it matches, the text in question is not a signature." 174regexp. If it matches, the text in question is not a signature."
156 :type '(choice integer number function regexp) 175 :type '(choice (integer :value 200)
176 (number :value 4.0)
177 (function :value fun)
178 (regexp :value ".*"))
157 :group 'gnus-article-signature) 179 :group 'gnus-article-signature)
158 180
159(defcustom gnus-hidden-properties '(invisible t intangible t) 181(defcustom gnus-hidden-properties '(invisible t intangible t)
@@ -163,7 +185,7 @@ regexp. If it matches, the text in question is not a signature."
163 185
164(defcustom gnus-article-x-face-command 186(defcustom gnus-article-x-face-command
165 "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -" 187 "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -"
166 "String or function to be executed to display an X-Face header. 188 "*String or function to be executed to display an X-Face header.
167If it is a string, the command will be executed in a sub-shell 189If it is a string, the command will be executed in a sub-shell
168asynchronously. The compressed face will be piped to this command." 190asynchronously. The compressed face will be piped to this command."
169 :type 'string ;Leave function case to Lisp. 191 :type 'string ;Leave function case to Lisp.
@@ -193,7 +215,7 @@ asynchronously. The compressed face will be piped to this command."
193 (format format (car spec) (cadr spec)) 215 (format format (car spec) (cadr spec))
194 2 3 (intern (format "gnus-emphasis-%s" (nth 2 spec))))) 216 2 3 (intern (format "gnus-emphasis-%s" (nth 2 spec)))))
195 types))) 217 types)))
196 "Alist that says how to fontify certain phrases. 218 "*Alist that says how to fontify certain phrases.
197Each item looks like this: 219Each item looks like this:
198 220
199 (\"_\\\\(\\\\w+\\\\)_\" 0 1 'underline) 221 (\"_\\\\(\\\\w+\\\\)_\" 0 1 'underline)
@@ -242,8 +264,12 @@ Esample: (_/*word*/_)."
242 264
243(defcustom gnus-article-time-format "%a, %b %d %Y %T %Z" 265(defcustom gnus-article-time-format "%a, %b %d %Y %T %Z"
244 "Format for display of Date headers in article bodies. 266 "Format for display of Date headers in article bodies.
245See `format-time-zone' for the possible values." 267See `format-time-string' for the possible values.
246 :type 'string 268
269The variable can also be function, which should return a complete Date
270header. The function is called with one argument, the time, which can
271be fed to `format-time-string'."
272 :type '(choice string symbol)
247 :link '(custom-manual "(gnus)Article Date") 273 :link '(custom-manual "(gnus)Article Date")
248 :group 'gnus-article-washing) 274 :group 'gnus-article-washing)
249 275
@@ -268,7 +294,7 @@ each invocation of the saving commands."
268 :group 'gnus-article-saving 294 :group 'gnus-article-saving
269 :type '(choice (item always) 295 :type '(choice (item always)
270 (item :tag "never" nil) 296 (item :tag "never" nil)
271 (other :tag "once" t))) 297 (sexp :tag "once" :format "%t\n" :value t)))
272 298
273(defcustom gnus-saved-headers gnus-visible-headers 299(defcustom gnus-saved-headers gnus-visible-headers
274 "Headers to keep if `gnus-save-all-headers' is nil. 300 "Headers to keep if `gnus-save-all-headers' is nil.
@@ -327,7 +353,7 @@ LAST-FILE."
327(defcustom gnus-split-methods 353(defcustom gnus-split-methods
328 '((gnus-article-archive-name) 354 '((gnus-article-archive-name)
329 (gnus-article-nndoc-name)) 355 (gnus-article-nndoc-name))
330 "Variable used to suggest where articles are to be saved. 356 "*Variable used to suggest where articles are to be saved.
331For instance, if you would like to save articles related to Gnus in 357For instance, if you would like to save articles related to Gnus in
332the file \"gnus-stuff\", and articles related to VM in \"vm-stuff\", 358the file \"gnus-stuff\", and articles related to VM in \"vm-stuff\",
333you could set this variable to something like: 359you could set this variable to something like:
@@ -347,9 +373,9 @@ If this form or function returns a string, this string will be used as
347a possible file name; and if it returns a non-nil list, that list will 373a possible file name; and if it returns a non-nil list, that list will
348be used as possible file names." 374be used as possible file names."
349 :group 'gnus-article-saving 375 :group 'gnus-article-saving
350 :type '(repeat (choice (list function) 376 :type '(repeat (choice (list :value (fun) function)
351 (cons regexp (repeat string)) 377 (cons :value ("" "") regexp (repeat string))
352 sexp))) 378 (sexp :value nil))))
353 379
354(defcustom gnus-strict-mime t 380(defcustom gnus-strict-mime t
355 "*If nil, MIME-decode even if there is no Mime-Version header." 381 "*If nil, MIME-decode even if there is no Mime-Version header."
@@ -377,8 +403,7 @@ The function is called from the article buffer."
377 "Function to decode ``localized RFC 822 messages''. 403 "Function to decode ``localized RFC 822 messages''.
378The function is called from the article buffer." 404The function is called from the article buffer."
379 :group 'gnus-article-mime 405 :group 'gnus-article-mime
380 :type 'function 406 :type 'function)
381 :version "20.3")
382 407
383(defcustom gnus-page-delimiter "^\^L" 408(defcustom gnus-page-delimiter "^\^L"
384 "*Regexp describing what to use as article page delimiters. 409 "*Regexp describing what to use as article page delimiters.
@@ -412,8 +437,7 @@ If you want to run a special decoding program like nkf, use this hook."
412(defcustom gnus-article-hide-pgp-hook nil 437(defcustom gnus-article-hide-pgp-hook nil
413 "*A hook called after successfully hiding a PGP signature." 438 "*A hook called after successfully hiding a PGP signature."
414 :type 'hook 439 :type 'hook
415 :group 'gnus-article-various 440 :group 'gnus-article-various)
416 :version "20.3")
417 441
418(defcustom gnus-article-button-face 'bold 442(defcustom gnus-article-button-face 'bold
419 "Face used for highlighting buttons in the article buffer. 443 "Face used for highlighting buttons in the article buffer.
@@ -448,12 +472,12 @@ Obsolete; use the face `gnus-signature-face' for customizations instead."
448(defface gnus-header-from-face 472(defface gnus-header-from-face
449 '((((class color) 473 '((((class color)
450 (background dark)) 474 (background dark))
451 (:foreground "spring green" :bold t)) 475 (:foreground "spring green"))
452 (((class color) 476 (((class color)
453 (background light)) 477 (background light))
454 (:foreground "red3" :bold t)) 478 (:foreground "red3"))
455 (t 479 (t
456 (:bold t :italic t))) 480 (:italic t)))
457 "Face used for displaying from headers." 481 "Face used for displaying from headers."
458 :group 'gnus-article-headers 482 :group 'gnus-article-headers
459 :group 'gnus-article-highlight) 483 :group 'gnus-article-highlight)
@@ -461,10 +485,10 @@ Obsolete; use the face `gnus-signature-face' for customizations instead."
461(defface gnus-header-subject-face 485(defface gnus-header-subject-face
462 '((((class color) 486 '((((class color)
463 (background dark)) 487 (background dark))
464 (:foreground "SeaGreen3" :bold t)) 488 (:foreground "SeaGreen3"))
465 (((class color) 489 (((class color)
466 (background light)) 490 (background light))
467 (:foreground "red4" :bold t)) 491 (:foreground "red4"))
468 (t 492 (t
469 (:bold t :italic t))) 493 (:bold t :italic t)))
470 "Face used for displaying subject headers." 494 "Face used for displaying subject headers."
@@ -474,12 +498,12 @@ Obsolete; use the face `gnus-signature-face' for customizations instead."
474(defface gnus-header-newsgroups-face 498(defface gnus-header-newsgroups-face
475 '((((class color) 499 '((((class color)
476 (background dark)) 500 (background dark))
477 (:foreground "yellow" :bold t :italic t)) 501 (:foreground "yellow" :italic t))
478 (((class color) 502 (((class color)
479 (background light)) 503 (background light))
480 (:foreground "MidnightBlue" :bold t :italic t)) 504 (:foreground "MidnightBlue" :italic t))
481 (t 505 (t
482 (:bold t :italic t))) 506 (:italic t)))
483 "Face used for displaying newsgroups headers." 507 "Face used for displaying newsgroups headers."
484 :group 'gnus-article-headers 508 :group 'gnus-article-headers
485 :group 'gnus-article-highlight) 509 :group 'gnus-article-highlight)
@@ -514,7 +538,7 @@ Obsolete; use the face `gnus-signature-face' for customizations instead."
514 ("Subject" nil gnus-header-subject-face) 538 ("Subject" nil gnus-header-subject-face)
515 ("Newsgroups:.*," nil gnus-header-newsgroups-face) 539 ("Newsgroups:.*," nil gnus-header-newsgroups-face)
516 ("" gnus-header-name-face gnus-header-content-face)) 540 ("" gnus-header-name-face gnus-header-content-face))
517 "Controls highlighting of article header. 541 "*Controls highlighting of article header.
518 542
519An alist of the form (HEADER NAME CONTENT). 543An alist of the form (HEADER NAME CONTENT).
520 544
@@ -537,6 +561,9 @@ displayed by the first non-nil matching CONTENT face."
537 561
538;;; Internal variables 562;;; Internal variables
539 563
564(defvar article-lapsed-timer nil)
565(defvar gnus-article-current-summary nil)
566
540(defvar gnus-article-mode-syntax-table 567(defvar gnus-article-mode-syntax-table
541 (let ((table (copy-syntax-table text-mode-syntax-table))) 568 (let ((table (copy-syntax-table text-mode-syntax-table)))
542 (modify-syntax-entry ?- "w" table) 569 (modify-syntax-entry ?- "w" table)
@@ -549,8 +576,8 @@ Initialized from `text-mode-syntax-table.")
549(defvar gnus-save-article-buffer nil) 576(defvar gnus-save-article-buffer nil)
550 577
551(defvar gnus-article-mode-line-format-alist 578(defvar gnus-article-mode-line-format-alist
552 (nconc '((?w (gnus-article-wash-status) ?s)) 579 (nconc '((?w (gnus-article-wash-status) ?s))
553 gnus-summary-mode-line-format-alist)) 580 gnus-summary-mode-line-format-alist))
554 581
555(defvar gnus-number-of-articles-to-be-saved nil) 582(defvar gnus-number-of-articles-to-be-saved nil)
556 583
@@ -577,7 +604,7 @@ Initialized from `text-mode-syntax-table.")
577 b e (cons 'article-type (cons type gnus-hidden-properties)))) 604 b e (cons 'article-type (cons type gnus-hidden-properties))))
578 605
579(defun gnus-article-unhide-text-type (b e type) 606(defun gnus-article-unhide-text-type (b e type)
580 "Hide text of TYPE between B and E." 607 "Unhide text of TYPE between B and E."
581 (remove-text-properties 608 (remove-text-properties
582 b e (cons 'article-type (cons type gnus-hidden-properties))) 609 b e (cons 'article-type (cons type gnus-hidden-properties)))
583 (when (memq 'intangible gnus-hidden-properties) 610 (when (memq 'intangible gnus-hidden-properties)
@@ -630,6 +657,7 @@ Initialized from `text-mode-syntax-table.")
630If given a negative prefix, always show; if given a positive prefix, 657If given a negative prefix, always show; if given a positive prefix,
631always hide." 658always hide."
632 (interactive (gnus-article-hidden-arg)) 659 (interactive (gnus-article-hidden-arg))
660 (current-buffer)
633 (if (gnus-article-check-hidden-text 'headers arg) 661 (if (gnus-article-check-hidden-text 'headers arg)
634 ;; Show boring headers as well. 662 ;; Show boring headers as well.
635 (gnus-article-show-hidden-text 'boring-headers) 663 (gnus-article-show-hidden-text 'boring-headers)
@@ -638,6 +666,7 @@ always hide."
638 (save-excursion 666 (save-excursion
639 (save-restriction 667 (save-restriction
640 (let ((buffer-read-only nil) 668 (let ((buffer-read-only nil)
669 (case-fold-search t)
641 (props (nconc (list 'article-type 'headers) 670 (props (nconc (list 'article-type 'headers)
642 gnus-hidden-properties)) 671 gnus-hidden-properties))
643 (max (1+ (length gnus-sorted-header-list))) 672 (max (1+ (length gnus-sorted-header-list)))
@@ -654,7 +683,7 @@ always hide."
654 (listp gnus-visible-headers)) 683 (listp gnus-visible-headers))
655 (mapconcat 'identity gnus-visible-headers "\\|")))) 684 (mapconcat 'identity gnus-visible-headers "\\|"))))
656 (inhibit-point-motion-hooks t) 685 (inhibit-point-motion-hooks t)
657 want-list beg) 686 beg)
658 ;; First we narrow to just the headers. 687 ;; First we narrow to just the headers.
659 (widen) 688 (widen)
660 (goto-char (point-min)) 689 (goto-char (point-min))
@@ -755,7 +784,25 @@ always hide."
755 (when (and date 784 (when (and date
756 (< (gnus-days-between (current-time-string) date) 785 (< (gnus-days-between (current-time-string) date)
757 4)) 786 4))
758 (gnus-article-hide-header "date"))))))))))) 787 (gnus-article-hide-header "date"))))
788 ((eq elem 'long-to)
789 (let ((to (message-fetch-field "to")))
790 (when (> (length to) 1024)
791 (gnus-article-hide-header "to"))))
792 ((eq elem 'many-to)
793 (let ((to-count 0))
794 (goto-char (point-min))
795 (while (re-search-forward "^to:" nil t)
796 (setq to-count (1+ to-count)))
797 (when (> to-count 1)
798 (while (> to-count 0)
799 (goto-char (point-min))
800 (save-restriction
801 (re-search-forward "^to:" nil nil to-count)
802 (forward-line -1)
803 (narrow-to-region (point) (point-max))
804 (gnus-article-hide-header "to"))
805 (setq to-count (1- to-count)))))))))))))
759 806
760(defun gnus-article-hide-header (header) 807(defun gnus-article-hide-header (header)
761 (save-excursion 808 (save-excursion
@@ -770,7 +817,29 @@ always hide."
770 (point-max))) 817 (point-max)))
771 'boring-headers)))) 818 'boring-headers))))
772 819
773;; Written by Per Abrahamsen <amanda@iesd.auc.dk>. 820(defun article-treat-dumbquotes ()
821 "Translate M******** sm*rtq**t*s into proper text."
822 (interactive)
823 (article-translate-characters "\221\222\223\223" "`'\"\""))
824
825(defun article-translate-characters (from to)
826 "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
828characters to translate to."
829 (save-excursion
830 (goto-char (point-min))
831 (when (search-forward "\n\n" nil t)
832 (let ((buffer-read-only nil)
833 (x (make-string 225 ?x))
834 (i -1))
835 (while (< (incf i) (length x))
836 (aset x i i))
837 (setq i 0)
838 (while (< i (length from))
839 (aset x (aref from i) (aref to i))
840 (incf i))
841 (translate-region (point) (point-max) x)))))
842
774(defun article-treat-overstrike () 843(defun article-treat-overstrike ()
775 "Translate overstrikes into bold text." 844 "Translate overstrikes into bold text."
776 (interactive) 845 (interactive)
@@ -848,13 +917,14 @@ always hide."
848 (when (process-status "article-x-face") 917 (when (process-status "article-x-face")
849 (delete-process "article-x-face")) 918 (delete-process "article-x-face"))
850 (let ((inhibit-point-motion-hooks t) 919 (let ((inhibit-point-motion-hooks t)
851 (case-fold-search nil) 920 (case-fold-search t)
852 from) 921 from last)
853 (save-restriction 922 (save-restriction
854 (nnheader-narrow-to-headers) 923 (nnheader-narrow-to-headers)
855 (setq from (message-fetch-field "from")) 924 (setq from (message-fetch-field "from"))
856 (goto-char (point-min)) 925 (goto-char (point-min))
857 (while (and gnus-article-x-face-command 926 (while (and gnus-article-x-face-command
927 (not last)
858 (or force 928 (or force
859 ;; Check whether this face is censored. 929 ;; Check whether this face is censored.
860 (not gnus-article-x-face-too-ugly) 930 (not gnus-article-x-face-too-ugly)
@@ -863,6 +933,12 @@ always hide."
863 from)))) 933 from))))
864 ;; Has to be present. 934 ;; Has to be present.
865 (re-search-forward "^X-Face: " nil t)) 935 (re-search-forward "^X-Face: " nil t))
936 ;; This used to try to do multiple faces (`while' instead of
937 ;; `when' above), but (a) sending multiple EOFs to xv doesn't
938 ;; work (b) it can crash some versions of Emacs (c) are
939 ;; multiple faces really something to encourage?
940 (when (stringp gnus-article-x-face-command)
941 (setq last t))
866 ;; We now have the area of the buffer where the X-Face is stored. 942 ;; We now have the area of the buffer where the X-Face is stored.
867 (save-excursion 943 (save-excursion
868 (let ((beg (point)) 944 (let ((beg (point))
@@ -975,29 +1051,27 @@ always hide."
975 (goto-char (point-min)) 1051 (goto-char (point-min))
976 ;; Hide the "header". 1052 ;; Hide the "header".
977 (when (search-forward "\n-----BEGIN PGP SIGNED MESSAGE-----\n" nil t) 1053 (when (search-forward "\n-----BEGIN PGP SIGNED MESSAGE-----\n" nil t)
978 (gnus-article-hide-text-type (1+ (match-beginning 0)) 1054 (delete-region (1+ (match-beginning 0)) (match-end 0))
979 (match-end 0) 'pgp)
980 (setq beg (point)) 1055 (setq beg (point))
981 ;; Hide the actual signature. 1056 ;; Hide the actual signature.
982 (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t) 1057 (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t)
983 (setq end (1+ (match-beginning 0))) 1058 (setq end (1+ (match-beginning 0)))
984 (gnus-article-hide-text-type 1059 (delete-region
985 end 1060 end
986 (if (search-forward "\n-----END PGP SIGNATURE-----\n" nil t) 1061 (if (search-forward "\n-----END PGP SIGNATURE-----\n" nil t)
987 (match-end 0) 1062 (match-end 0)
988 ;; Perhaps we shouldn't hide to the end of the buffer 1063 ;; Perhaps we shouldn't hide to the end of the buffer
989 ;; if there is no end to the signature? 1064 ;; if there is no end to the signature?
990 (point-max)) 1065 (point-max))))
991 'pgp))
992 ;; Hide "- " PGP quotation markers. 1066 ;; Hide "- " PGP quotation markers.
993 (when (and beg end) 1067 (when (and beg end)
994 (narrow-to-region beg end) 1068 (narrow-to-region beg end)
995 (goto-char (point-min)) 1069 (goto-char (point-min))
996 (while (re-search-forward "^- " nil t) 1070 (while (re-search-forward "^- " nil t)
997 (gnus-article-hide-text-type 1071 (delete-region
998 (match-beginning 0) (match-end 0) 'pgp)) 1072 (match-beginning 0) (match-end 0)))
999 (widen)) 1073 (widen))
1000 (run-hooks 'gnus-article-hide-pgp-hook)))))) 1074 (gnus-run-hooks 'gnus-article-hide-pgp-hook))))))
1001 1075
1002(defun article-hide-pem (&optional arg) 1076(defun article-hide-pem (&optional arg)
1003 "Toggle hiding of any PEM headers and signatures in the current article. 1077 "Toggle hiding of any PEM headers and signatures in the current article.
@@ -1087,42 +1161,54 @@ always hide."
1087 (article-remove-trailing-blank-lines) 1161 (article-remove-trailing-blank-lines)
1088 (article-strip-multiple-blank-lines)) 1162 (article-strip-multiple-blank-lines))
1089 1163
1164(defun article-strip-all-blank-lines ()
1165 "Strip all blank lines."
1166 (interactive)
1167 (save-excursion
1168 (let ((inhibit-point-motion-hooks t)
1169 buffer-read-only)
1170 (goto-char (point-min))
1171 (search-forward "\n\n" nil t)
1172 (while (re-search-forward "^[ \t]*\n" nil t)
1173 (replace-match "" t t)))))
1174
1090(defvar mime::preview/content-list) 1175(defvar mime::preview/content-list)
1091(defvar mime::preview-content-info/point-min) 1176(defvar mime::preview-content-info/point-min)
1092(defun gnus-article-narrow-to-signature () 1177(defun gnus-article-narrow-to-signature ()
1093 "Narrow to the signature; return t if a signature is found, else nil." 1178 "Narrow to the signature; return t if a signature is found, else nil."
1094 (widen) 1179 (widen)
1095 (when (and (boundp 'mime::preview/content-list) 1180 (let ((inhibit-point-motion-hooks t))
1096 mime::preview/content-list) 1181 (when (and (boundp 'mime::preview/content-list)
1097 ;; We have a MIMEish article, so we use the MIME data to narrow. 1182 mime::preview/content-list)
1098 (let ((pcinfo (car (last mime::preview/content-list)))) 1183 ;; We have a MIMEish article, so we use the MIME data to narrow.
1099 (ignore-errors 1184 (let ((pcinfo (car (last mime::preview/content-list))))
1100 (narrow-to-region 1185 (ignore-errors
1101 (funcall (intern "mime::preview-content-info/point-min") pcinfo) 1186 (narrow-to-region
1102 (point-max))))) 1187 (funcall (intern "mime::preview-content-info/point-min") pcinfo)
1103 1188 (point-max)))))
1104 (when (gnus-article-search-signature) 1189
1105 (forward-line 1) 1190 (when (gnus-article-search-signature)
1106 ;; Check whether we have some limits to what we consider 1191 (forward-line 1)
1107 ;; to be a signature. 1192 ;; Check whether we have some limits to what we consider
1108 (let ((limits (if (listp gnus-signature-limit) gnus-signature-limit 1193 ;; to be a signature.
1109 (list gnus-signature-limit))) 1194 (let ((limits (if (listp gnus-signature-limit) gnus-signature-limit
1110 limit limited) 1195 (list gnus-signature-limit)))
1111 (while (setq limit (pop limits)) 1196 limit limited)
1112 (if (or (and (integerp limit) 1197 (while (setq limit (pop limits))
1113 (< (- (point-max) (point)) limit)) 1198 (if (or (and (integerp limit)
1114 (and (floatp limit) 1199 (< (- (point-max) (point)) limit))
1115 (< (count-lines (point) (point-max)) limit)) 1200 (and (floatp limit)
1116 (and (gnus-functionp limit) 1201 (< (count-lines (point) (point-max)) limit))
1117 (funcall limit)) 1202 (and (gnus-functionp limit)
1118 (and (stringp limit) 1203 (funcall limit))
1119 (not (re-search-forward limit nil t)))) 1204 (and (stringp limit)
1120 () ; This limit did not succeed. 1205 (not (re-search-forward limit nil t))))
1121 (setq limited t 1206 () ; This limit did not succeed.
1122 limits nil))) 1207 (setq limited t
1123 (unless limited 1208 limits nil)))
1124 (narrow-to-region (point) (point-max)) 1209 (unless limited
1125 t)))) 1210 (narrow-to-region (point) (point-max))
1211 t)))))
1126 1212
1127(defun gnus-article-search-signature () 1213(defun gnus-article-search-signature ()
1128 "Search the current buffer for the signature separator. 1214 "Search the current buffer for the signature separator.
@@ -1142,7 +1228,8 @@ Put point at the beginning of the signature separator."
1142 1228
1143(eval-and-compile 1229(eval-and-compile
1144 (autoload 'w3-display "w3-parse") 1230 (autoload 'w3-display "w3-parse")
1145 (autoload 'w3-do-setup "w3" "" t)) 1231 (autoload 'w3-do-setup "w3" "" t)
1232 (autoload 'w3-region "w3-display" "" t))
1146 1233
1147(defun gnus-article-treat-html () 1234(defun gnus-article-treat-html ()
1148 "Render HTML." 1235 "Render HTML."
@@ -1198,8 +1285,7 @@ means show, 0 means toggle."
1198 1285
1199(defun gnus-article-hidden-text-p (type) 1286(defun gnus-article-hidden-text-p (type)
1200 "Say whether the current buffer contains hidden text of type TYPE." 1287 "Say whether the current buffer contains hidden text of type TYPE."
1201 (let ((start (point-min)) 1288 (let ((pos (text-property-any (point-min) (point-max) 'article-type type)))
1202 (pos (text-property-any (point-min) (point-max) 'article-type type)))
1203 (while (and pos 1289 (while (and pos
1204 (not (get-text-property pos 'invisible))) 1290 (not (get-text-property pos 'invisible)))
1205 (setq pos 1291 (setq pos
@@ -1249,7 +1335,7 @@ how much time has lapsed since DATE."
1249 header)) 1335 header))
1250 (date-regexp "^Date:[ \t]\\|^X-Sent:[ \t]") 1336 (date-regexp "^Date:[ \t]\\|^X-Sent:[ \t]")
1251 (inhibit-point-motion-hooks t) 1337 (inhibit-point-motion-hooks t)
1252 bface eface) 1338 bface eface newline)
1253 (when (and date (not (string= date ""))) 1339 (when (and date (not (string= date "")))
1254 (save-excursion 1340 (save-excursion
1255 (save-restriction 1341 (save-restriction
@@ -1261,17 +1347,22 @@ how much time has lapsed since DATE."
1261 (setq bface (get-text-property (gnus-point-at-bol) 'face) 1347 (setq bface (get-text-property (gnus-point-at-bol) 'face)
1262 eface (get-text-property (1- (gnus-point-at-eol)) 1348 eface (get-text-property (1- (gnus-point-at-eol))
1263 'face)) 1349 'face))
1264 (message-remove-header date-regexp t) 1350 (delete-region (progn (beginning-of-line) (point))
1351 (progn (end-of-line) (point)))
1265 (beginning-of-line)) 1352 (beginning-of-line))
1266 (goto-char (point-max))) 1353 (goto-char (point-max))
1354 (setq newline t))
1267 (insert (article-make-date-line date type)) 1355 (insert (article-make-date-line date type))
1268 ;; Do highlighting. 1356 ;; Do highlighting.
1269 (forward-line -1) 1357 (beginning-of-line)
1270 (when (looking-at "\\([^:]+\\): *\\(.*\\)$") 1358 (when (looking-at "\\([^:]+\\): *\\(.*\\)$")
1271 (put-text-property (match-beginning 1) (match-end 1) 1359 (put-text-property (match-beginning 1) (1+ (match-end 1))
1272 'face bface) 1360 'face bface)
1273 (put-text-property (match-beginning 2) (match-end 2) 1361 (put-text-property (match-beginning 2) (match-end 2)
1274 'face eface)))))))) 1362 'face eface))
1363 (when newline
1364 (end-of-line)
1365 (insert "\n"))))))))
1275 1366
1276(defun article-make-date-line (date type) 1367(defun article-make-date-line (date type)
1277 "Return a DATE line of TYPE." 1368 "Return a DATE line of TYPE."
@@ -1283,28 +1374,41 @@ how much time has lapsed since DATE."
1283 ((eq type 'local) 1374 ((eq type 'local)
1284 (concat "Date: " (condition-case () 1375 (concat "Date: " (condition-case ()
1285 (timezone-make-date-arpa-standard date) 1376 (timezone-make-date-arpa-standard date)
1286 (error date)) 1377 (error date))))
1287 "\n"))
1288 ;; Convert to Universal Time. 1378 ;; Convert to Universal Time.
1289 ((eq type 'ut) 1379 ((eq type 'ut)
1290 (concat "Date: " 1380 (concat "Date: "
1291 (condition-case () 1381 (condition-case ()
1292 (timezone-make-date-arpa-standard date nil "UT") 1382 (timezone-make-date-arpa-standard date nil "UT")
1293 (error date)) 1383 (error date))))
1294 "\n"))
1295 ;; Get the original date from the article. 1384 ;; Get the original date from the article.
1296 ((eq type 'original) 1385 ((eq type 'original)
1297 (concat "Date: " date "\n")) 1386 (concat "Date: " date))
1298 ;; Let the user define the format. 1387 ;; Let the user define the format.
1299 ((eq type 'user) 1388 ((eq type 'user)
1389 (if (gnus-functionp gnus-article-time-format)
1390 (funcall
1391 gnus-article-time-format
1392 (ignore-errors
1393 (gnus-encode-date
1394 (timezone-make-date-arpa-standard
1395 date nil "UT"))))
1396 (concat
1397 "Date: "
1398 (format-time-string gnus-article-time-format
1399 (ignore-errors
1400 (gnus-encode-date
1401 (timezone-make-date-arpa-standard
1402 date nil "UT")))))))
1403 ;; ISO 8601.
1404 ((eq type 'iso8601)
1300 (concat 1405 (concat
1301 "Date: " 1406 "Date: "
1302 (format-time-string gnus-article-time-format 1407 (format-time-string "%Y%M%DT%h%m%s"
1303 (ignore-errors 1408 (ignore-errors
1304 (gnus-encode-date 1409 (gnus-encode-date
1305 (timezone-make-date-arpa-standard 1410 (timezone-make-date-arpa-standard
1306 date nil "UT")))) 1411 date nil "UT"))))))
1307 "\n"))
1308 ;; Do an X-Sent lapsed format. 1412 ;; Do an X-Sent lapsed format.
1309 ((eq type 'lapsed) 1413 ((eq type 'lapsed)
1310 ;; If the date is seriously mangled, the timezone functions are 1414 ;; If the date is seriously mangled, the timezone functions are
@@ -1327,9 +1431,9 @@ how much time has lapsed since DATE."
1327 num prev) 1431 num prev)
1328 (cond 1432 (cond
1329 ((null real-time) 1433 ((null real-time)
1330 "X-Sent: Unknown\n") 1434 "X-Sent: Unknown")
1331 ((zerop sec) 1435 ((zerop sec)
1332 "X-Sent: Now\n") 1436 "X-Sent: Now")
1333 (t 1437 (t
1334 (concat 1438 (concat
1335 "X-Sent: " 1439 "X-Sent: "
@@ -1355,8 +1459,8 @@ how much time has lapsed since DATE."
1355 ;; If dates are odd, then it might appear like the 1459 ;; If dates are odd, then it might appear like the
1356 ;; article was sent in the future. 1460 ;; article was sent in the future.
1357 (if (> real-sec 0) 1461 (if (> real-sec 0)
1358 " ago\n" 1462 " ago"
1359 " in the future\n")))))) 1463 " in the future"))))))
1360 (t 1464 (t
1361 (error "Unknown conversion type: %s" type)))) 1465 (error "Unknown conversion type: %s" type))))
1362 1466
@@ -1377,12 +1481,46 @@ function and want to see what the date was before converting."
1377 (interactive (list t)) 1481 (interactive (list t))
1378 (article-date-ut 'lapsed highlight)) 1482 (article-date-ut 'lapsed highlight))
1379 1483
1484(defun article-update-date-lapsed ()
1485 "Function to be run from a timer to update the lapsed time line."
1486 (let (deactivate-mark)
1487 (save-excursion
1488 (ignore-errors
1489 (when (gnus-buffer-live-p gnus-article-buffer)
1490 (set-buffer gnus-article-buffer)
1491 (goto-char (point-min))
1492 (when (re-search-forward "^X-Sent:" nil t)
1493 (article-date-lapsed t)))))))
1494
1495(defun gnus-start-date-timer (&optional n)
1496 "Start a timer to update the X-Sent header in the article buffers.
1497The numerical prefix says how frequently (in seconds) the function
1498is to run."
1499 (interactive "p")
1500 (unless n
1501 (setq n 1))
1502 (gnus-stop-date-timer)
1503 (setq article-lapsed-timer
1504 (nnheader-run-at-time 1 n 'article-update-date-lapsed)))
1505
1506(defun gnus-stop-date-timer ()
1507 "Stop the X-Sent timer."
1508 (interactive)
1509 (when article-lapsed-timer
1510 (nnheader-cancel-timer article-lapsed-timer)
1511 (setq article-lapsed-timer nil)))
1512
1380(defun article-date-user (&optional highlight) 1513(defun article-date-user (&optional highlight)
1381 "Convert the current article date to the user-defined format. 1514 "Convert the current article date to the user-defined format.
1382This format is defined by the `gnus-article-time-format' variable." 1515This format is defined by the `gnus-article-time-format' variable."
1383 (interactive (list t)) 1516 (interactive (list t))
1384 (article-date-ut 'user highlight)) 1517 (article-date-ut 'user highlight))
1385 1518
1519(defun article-date-iso8601 (&optional highlight)
1520 "Convert the current article date to ISO8601."
1521 (interactive (list t))
1522 (article-date-ut 'iso8601 highlight))
1523
1386(defun article-show-all () 1524(defun article-show-all ()
1387 "Show all hidden text in the article buffer." 1525 "Show all hidden text in the article buffer."
1388 (interactive) 1526 (interactive)
@@ -1431,7 +1569,9 @@ This format is defined by the `gnus-article-time-format' variable."
1431 (let ((gnus-visible-headers 1569 (let ((gnus-visible-headers
1432 (or gnus-saved-headers gnus-visible-headers)) 1570 (or gnus-saved-headers gnus-visible-headers))
1433 (gnus-article-buffer save-buffer)) 1571 (gnus-article-buffer save-buffer))
1434 (gnus-article-hide-headers 1 t))) 1572 (save-excursion
1573 (set-buffer save-buffer)
1574 (article-hide-headers 1 t))))
1435 (save-window-excursion 1575 (save-window-excursion
1436 (if (not gnus-default-article-saver) 1576 (if (not gnus-default-article-saver)
1437 (error "No default saver is defined") 1577 (error "No default saver is defined")
@@ -1448,7 +1588,7 @@ This format is defined by the `gnus-article-time-format' variable."
1448 (gnus-number-of-articles-to-be-saved 1588 (gnus-number-of-articles-to-be-saved
1449 (when (eq gnus-prompt-before-saving t) 1589 (when (eq gnus-prompt-before-saving t)
1450 num))) ; Magic 1590 num))) ; Magic
1451 (set-buffer gnus-summary-buffer) 1591 (set-buffer gnus-article-current-summary)
1452 (funcall gnus-default-article-saver filename))))) 1592 (funcall gnus-default-article-saver filename)))))
1453 1593
1454(defun gnus-read-save-file-name (prompt &optional filename 1594(defun gnus-read-save-file-name (prompt &optional filename
@@ -1545,8 +1685,6 @@ This format is defined by the `gnus-article-time-format' variable."
1545 "Append this article to Rmail file. 1685 "Append this article to Rmail file.
1546Optional argument FILENAME specifies file name. 1686Optional argument FILENAME specifies file name.
1547Directory to save to is default to `gnus-article-save-directory'." 1687Directory to save to is default to `gnus-article-save-directory'."
1548 (interactive)
1549 (gnus-set-global-variables)
1550 (setq filename (gnus-read-save-file-name 1688 (setq filename (gnus-read-save-file-name
1551 "Save %s in rmail file:" filename 1689 "Save %s in rmail file:" filename
1552 gnus-rmail-save-name gnus-newsgroup-name 1690 gnus-rmail-save-name gnus-newsgroup-name
@@ -1555,14 +1693,13 @@ Directory to save to is default to `gnus-article-save-directory'."
1555 (save-excursion 1693 (save-excursion
1556 (save-restriction 1694 (save-restriction
1557 (widen) 1695 (widen)
1558 (gnus-output-to-rmail filename))))) 1696 (gnus-output-to-rmail filename))))
1697 filename)
1559 1698
1560(defun gnus-summary-save-in-mail (&optional filename) 1699(defun gnus-summary-save-in-mail (&optional filename)
1561 "Append this article to Unix mail file. 1700 "Append this article to Unix mail file.
1562Optional argument FILENAME specifies file name. 1701Optional argument FILENAME specifies file name.
1563Directory to save to is default to `gnus-article-save-directory'." 1702Directory to save to is default to `gnus-article-save-directory'."
1564 (interactive)
1565 (gnus-set-global-variables)
1566 (setq filename (gnus-read-save-file-name 1703 (setq filename (gnus-read-save-file-name
1567 "Save %s in Unix mail file:" filename 1704 "Save %s in Unix mail file:" filename
1568 gnus-mail-save-name gnus-newsgroup-name 1705 gnus-mail-save-name gnus-newsgroup-name
@@ -1574,14 +1711,13 @@ Directory to save to is default to `gnus-article-save-directory'."
1574 (if (and (file-readable-p filename) 1711 (if (and (file-readable-p filename)
1575 (mail-file-babyl-p filename)) 1712 (mail-file-babyl-p filename))
1576 (gnus-output-to-rmail filename t) 1713 (gnus-output-to-rmail filename t)
1577 (gnus-output-to-mail filename)))))) 1714 (gnus-output-to-mail filename)))))
1715 filename)
1578 1716
1579(defun gnus-summary-save-in-file (&optional filename overwrite) 1717(defun gnus-summary-save-in-file (&optional filename overwrite)
1580 "Append this article to file. 1718 "Append this article to file.
1581Optional argument FILENAME specifies file name. 1719Optional argument FILENAME specifies file name.
1582Directory to save to is default to `gnus-article-save-directory'." 1720Directory to save to is default to `gnus-article-save-directory'."
1583 (interactive)
1584 (gnus-set-global-variables)
1585 (setq filename (gnus-read-save-file-name 1721 (setq filename (gnus-read-save-file-name
1586 "Save %s in file:" filename 1722 "Save %s in file:" filename
1587 gnus-file-save-name gnus-newsgroup-name 1723 gnus-file-save-name gnus-newsgroup-name
@@ -1593,21 +1729,19 @@ Directory to save to is default to `gnus-article-save-directory'."
1593 (when (and overwrite 1729 (when (and overwrite
1594 (file-exists-p filename)) 1730 (file-exists-p filename))
1595 (delete-file filename)) 1731 (delete-file filename))
1596 (gnus-output-to-file filename))))) 1732 (gnus-output-to-file filename))))
1733 filename)
1597 1734
1598(defun gnus-summary-write-to-file (&optional filename) 1735(defun gnus-summary-write-to-file (&optional filename)
1599 "Write this article to a file. 1736 "Write this article to a file.
1600Optional argument FILENAME specifies file name. 1737Optional argument FILENAME specifies file name.
1601The directory to save in defaults to `gnus-article-save-directory'." 1738The directory to save in defaults to `gnus-article-save-directory'."
1602 (interactive)
1603 (gnus-summary-save-in-file nil t)) 1739 (gnus-summary-save-in-file nil t))
1604 1740
1605(defun gnus-summary-save-body-in-file (&optional filename) 1741(defun gnus-summary-save-body-in-file (&optional filename)
1606 "Append this article body to a file. 1742 "Append this article body to a file.
1607Optional argument FILENAME specifies file name. 1743Optional argument FILENAME specifies file name.
1608The directory to save in defaults to `gnus-article-save-directory'." 1744The directory to save in defaults to `gnus-article-save-directory'."
1609 (interactive)
1610 (gnus-set-global-variables)
1611 (setq filename (gnus-read-save-file-name 1745 (setq filename (gnus-read-save-file-name
1612 "Save %s body in file:" filename 1746 "Save %s body in file:" filename
1613 gnus-file-save-name gnus-newsgroup-name 1747 gnus-file-save-name gnus-newsgroup-name
@@ -1619,12 +1753,11 @@ The directory to save in defaults to `gnus-article-save-directory'."
1619 (goto-char (point-min)) 1753 (goto-char (point-min))
1620 (when (search-forward "\n\n" nil t) 1754 (when (search-forward "\n\n" nil t)
1621 (narrow-to-region (point) (point-max))) 1755 (narrow-to-region (point) (point-max)))
1622 (gnus-output-to-file filename))))) 1756 (gnus-output-to-file filename))))
1757 filename)
1623 1758
1624(defun gnus-summary-save-in-pipe (&optional command) 1759(defun gnus-summary-save-in-pipe (&optional command)
1625 "Pipe this article to subprocess." 1760 "Pipe this article to subprocess."
1626 (interactive)
1627 (gnus-set-global-variables)
1628 (setq command 1761 (setq command
1629 (cond ((eq command 'default) 1762 (cond ((eq command 'default)
1630 gnus-last-shell-command) 1763 gnus-last-shell-command)
@@ -1748,12 +1881,15 @@ If variable `gnus-use-long-file-name' is non-nil, it is
1748 article-strip-multiple-blank-lines 1881 article-strip-multiple-blank-lines
1749 article-strip-leading-space 1882 article-strip-leading-space
1750 article-strip-blank-lines 1883 article-strip-blank-lines
1884 article-strip-all-blank-lines
1751 article-date-local 1885 article-date-local
1886 article-date-iso8601
1752 article-date-original 1887 article-date-original
1753 article-date-ut 1888 article-date-ut
1754 article-date-user 1889 article-date-user
1755 article-date-lapsed 1890 article-date-lapsed
1756 article-emphasize 1891 article-emphasize
1892 article-treat-dumbquotes
1757 (article-show-all . gnus-article-show-all-headers)))) 1893 (article-show-all . gnus-article-show-all-headers))))
1758 1894
1759;;; 1895;;;
@@ -1800,7 +1936,8 @@ If variable `gnus-use-long-file-name' is non-nil, it is
1800 ["Scroll backwards" gnus-article-goto-prev-page t] 1936 ["Scroll backwards" gnus-article-goto-prev-page t]
1801 ["Show summary" gnus-article-show-summary t] 1937 ["Show summary" gnus-article-show-summary t]
1802 ["Fetch Message-ID at point" gnus-article-refer-article t] 1938 ["Fetch Message-ID at point" gnus-article-refer-article t]
1803 ["Mail to address at point" gnus-article-mail t])) 1939 ["Mail to address at point" gnus-article-mail t]
1940 ["Send a bug report" gnus-bug t]))
1804 1941
1805 (easy-menu-define 1942 (easy-menu-define
1806 gnus-article-treatment-menu gnus-article-mode-map "" 1943 gnus-article-treatment-menu gnus-article-mode-map ""
@@ -1812,16 +1949,13 @@ If variable `gnus-use-long-file-name' is non-nil, it is
1812 ["Remove carriage return" gnus-article-remove-cr t] 1949 ["Remove carriage return" gnus-article-remove-cr t]
1813 ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t])) 1950 ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t]))
1814 1951
1815 (when nil 1952 ;; Note "Commands" menu is defined in gnus-sum.el for consistency
1816 (when (boundp 'gnus-summary-article-menu)
1817 (define-key gnus-article-mode-map [menu-bar commands]
1818 (cons "Commands" gnus-summary-article-menu))))
1819 1953
1820 (when (boundp 'gnus-summary-post-menu) 1954 (when (boundp 'gnus-summary-post-menu)
1821 (define-key gnus-article-mode-map [menu-bar post] 1955 (define-key gnus-article-mode-map [menu-bar post]
1822 (cons "Post" gnus-summary-post-menu))) 1956 (cons "Post" gnus-summary-post-menu)))
1823 1957
1824 (run-hooks 'gnus-article-menu-hook))) 1958 (gnus-run-hooks 'gnus-article-menu-hook)))
1825 1959
1826(defun gnus-article-mode () 1960(defun gnus-article-mode ()
1827 "Major mode for displaying an article. 1961 "Major mode for displaying an article.
@@ -1841,7 +1975,6 @@ commands:
1841 (interactive) 1975 (interactive)
1842 (when (gnus-visual-p 'article-menu 'menu) 1976 (when (gnus-visual-p 'article-menu 'menu)
1843 (gnus-article-make-menu-bar)) 1977 (gnus-article-make-menu-bar))
1844 (kill-all-local-variables)
1845 (gnus-simplify-mode-line) 1978 (gnus-simplify-mode-line)
1846 (setq mode-name "Article") 1979 (setq mode-name "Article")
1847 (setq major-mode 'gnus-article-mode) 1980 (setq major-mode 'gnus-article-mode)
@@ -1851,13 +1984,14 @@ commands:
1851 (use-local-map gnus-article-mode-map) 1984 (use-local-map gnus-article-mode-map)
1852 (gnus-update-format-specifications nil 'article-mode) 1985 (gnus-update-format-specifications nil 'article-mode)
1853 (set (make-local-variable 'page-delimiter) gnus-page-delimiter) 1986 (set (make-local-variable 'page-delimiter) gnus-page-delimiter)
1854 (set (make-local-variable 'gnus-page-broken) nil) 1987 (make-local-variable 'gnus-page-broken)
1855 (set (make-local-variable 'gnus-button-marker-list) nil) 1988 (make-local-variable 'gnus-button-marker-list)
1989 (make-local-variable 'gnus-article-current-summary)
1856 (gnus-set-default-directory) 1990 (gnus-set-default-directory)
1857 (buffer-disable-undo (current-buffer)) 1991 (buffer-disable-undo (current-buffer))
1858 (setq buffer-read-only t) 1992 (setq buffer-read-only t)
1859 (set-syntax-table gnus-article-mode-syntax-table) 1993 (set-syntax-table gnus-article-mode-syntax-table)
1860 (run-hooks 'gnus-article-mode-hook)) 1994 (gnus-run-hooks 'gnus-article-mode-hook))
1861 1995
1862(defun gnus-article-setup-buffer () 1996(defun gnus-article-setup-buffer ()
1863 "Initialize the article buffer." 1997 "Initialize the article buffer."
@@ -1878,23 +2012,20 @@ commands:
1878 (gnus-set-global-variables))) 2012 (gnus-set-global-variables)))
1879 ;; Init original article buffer. 2013 ;; Init original article buffer.
1880 (save-excursion 2014 (save-excursion
1881 (set-buffer (get-buffer-create gnus-original-article-buffer)) 2015 (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
1882 (buffer-disable-undo (current-buffer)) 2016 (buffer-disable-undo (current-buffer))
1883 (setq major-mode 'gnus-original-article-mode) 2017 (setq major-mode 'gnus-original-article-mode)
1884 (gnus-add-current-to-buffer-list)
1885 (make-local-variable 'gnus-original-article)) 2018 (make-local-variable 'gnus-original-article))
1886 (if (get-buffer name) 2019 (if (get-buffer name)
1887 (save-excursion 2020 (save-excursion
1888 (set-buffer name) 2021 (set-buffer name)
1889 (buffer-disable-undo (current-buffer)) 2022 (buffer-disable-undo (current-buffer))
1890 (setq buffer-read-only t) 2023 (setq buffer-read-only t)
1891 (gnus-add-current-to-buffer-list)
1892 (unless (eq major-mode 'gnus-article-mode) 2024 (unless (eq major-mode 'gnus-article-mode)
1893 (gnus-article-mode)) 2025 (gnus-article-mode))
1894 (current-buffer)) 2026 (current-buffer))
1895 (save-excursion 2027 (save-excursion
1896 (set-buffer (get-buffer-create name)) 2028 (set-buffer (gnus-get-buffer-create name))
1897 (gnus-add-current-to-buffer-list)
1898 (gnus-article-mode) 2029 (gnus-article-mode)
1899 (make-local-variable 'gnus-summary-buffer) 2030 (make-local-variable 'gnus-summary-buffer)
1900 (current-buffer))))) 2031 (current-buffer)))))
@@ -1924,14 +2055,9 @@ If ALL-HEADERS is non-nil, no headers are hidden."
1924 (unless (eq major-mode 'gnus-summary-mode) 2055 (unless (eq major-mode 'gnus-summary-mode)
1925 (set-buffer gnus-summary-buffer)) 2056 (set-buffer gnus-summary-buffer))
1926 (setq gnus-summary-buffer (current-buffer)) 2057 (setq gnus-summary-buffer (current-buffer))
1927 ;; Make sure the connection to the server is alive.
1928 (unless (gnus-server-opened
1929 (gnus-find-method-for-group gnus-newsgroup-name))
1930 (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name))
1931 (gnus-request-group gnus-newsgroup-name t))
1932 (let* ((gnus-article (if header (mail-header-number header) article)) 2058 (let* ((gnus-article (if header (mail-header-number header) article))
1933 (summary-buffer (current-buffer)) 2059 (summary-buffer (current-buffer))
1934 (internal-hook gnus-article-internal-prepare-hook) 2060 (gnus-tmp-internal-hook gnus-article-internal-prepare-hook)
1935 (group gnus-newsgroup-name) 2061 (group gnus-newsgroup-name)
1936 result) 2062 result)
1937 (save-excursion 2063 (save-excursion
@@ -1952,17 +2078,21 @@ If ALL-HEADERS is non-nil, no headers are hidden."
1952 (cons gnus-newsgroup-name article)) 2078 (cons gnus-newsgroup-name article))
1953 (set-buffer gnus-summary-buffer) 2079 (set-buffer gnus-summary-buffer)
1954 (setq gnus-current-article article) 2080 (setq gnus-current-article article)
1955 (gnus-summary-mark-article article gnus-canceled-mark)) 2081 (if (eq (gnus-article-mark article) gnus-undownloaded-mark)
1956 (unless (memq article gnus-newsgroup-sparse) 2082 (progn
1957 (gnus-error 2083 (gnus-summary-set-agent-mark article)
1958 1 "No such article (may have expired or been canceled)"))) 2084 (message "Message marked for downloading"))
1959 (if (or (eq result 'pseudo) (eq result 'nneething)) 2085 (gnus-summary-mark-article article gnus-canceled-mark)
2086 (unless (memq article gnus-newsgroup-sparse)
2087 (gnus-error 1
2088 "No such article (may have expired or been canceled)")))))
2089 (if (or (eq result 'pseudo)
2090 (eq result 'nneething))
1960 (progn 2091 (progn
1961 (save-excursion 2092 (save-excursion
1962 (set-buffer summary-buffer) 2093 (set-buffer summary-buffer)
2094 (push article gnus-newsgroup-history)
1963 (setq gnus-last-article gnus-current-article 2095 (setq gnus-last-article gnus-current-article
1964 gnus-newsgroup-history (cons gnus-current-article
1965 gnus-newsgroup-history)
1966 gnus-current-article 0 2096 gnus-current-article 0
1967 gnus-current-headers nil 2097 gnus-current-headers nil
1968 gnus-article-current nil) 2098 gnus-article-current nil)
@@ -1980,9 +2110,8 @@ If ALL-HEADERS is non-nil, no headers are hidden."
1980 ;; `gnus-current-article' must be an article number. 2110 ;; `gnus-current-article' must be an article number.
1981 (save-excursion 2111 (save-excursion
1982 (set-buffer summary-buffer) 2112 (set-buffer summary-buffer)
2113 (push article gnus-newsgroup-history)
1983 (setq gnus-last-article gnus-current-article 2114 (setq gnus-last-article gnus-current-article
1984 gnus-newsgroup-history (cons gnus-current-article
1985 gnus-newsgroup-history)
1986 gnus-current-article article 2115 gnus-current-article article
1987 gnus-current-headers 2116 gnus-current-headers
1988 (gnus-summary-article-header gnus-current-article) 2117 (gnus-summary-article-header gnus-current-article)
@@ -1990,41 +2119,41 @@ If ALL-HEADERS is non-nil, no headers are hidden."
1990 (cons gnus-newsgroup-name gnus-current-article)) 2119 (cons gnus-newsgroup-name gnus-current-article))
1991 (unless (vectorp gnus-current-headers) 2120 (unless (vectorp gnus-current-headers)
1992 (setq gnus-current-headers nil)) 2121 (setq gnus-current-headers nil))
1993 (gnus-summary-show-thread) 2122 (gnus-summary-goto-subject gnus-current-article)
1994 (run-hooks 'gnus-mark-article-hook) 2123 (when (gnus-summary-show-thread)
2124 ;; If the summary buffer really was folded, the
2125 ;; previous goto may not actually have gone to
2126 ;; the right article, but the thread root instead.
2127 ;; So we go again.
2128 (gnus-summary-goto-subject gnus-current-article))
2129 (gnus-run-hooks 'gnus-mark-article-hook)
1995 (gnus-set-mode-line 'summary) 2130 (gnus-set-mode-line 'summary)
1996 (when (gnus-visual-p 'article-highlight 'highlight) 2131 (when (gnus-visual-p 'article-highlight 'highlight)
1997 (run-hooks 'gnus-visual-mark-article-hook)) 2132 (gnus-run-hooks 'gnus-visual-mark-article-hook))
1998 ;; Set the global newsgroup variables here. 2133 ;; Set the global newsgroup variables here.
1999 ;; Suggested by Jim Sisolak 2134 ;; Suggested by Jim Sisolak
2000 ;; <sisolak@trans4.neep.wisc.edu>. 2135 ;; <sisolak@trans4.neep.wisc.edu>.
2001 (gnus-set-global-variables) 2136 (gnus-set-global-variables)
2002 (setq gnus-have-all-headers 2137 (setq gnus-have-all-headers
2003 (or all-headers gnus-show-all-headers)) 2138 (or all-headers gnus-show-all-headers))))
2004 (and gnus-use-cache
2005 (vectorp (gnus-summary-article-header article))
2006 (gnus-cache-possibly-enter-article
2007 group article
2008 (gnus-summary-article-header article)
2009 (memq article gnus-newsgroup-marked)
2010 (memq article gnus-newsgroup-dormant)
2011 (memq article gnus-newsgroup-unreads)))))
2012 (when (or (numberp article) 2139 (when (or (numberp article)
2013 (stringp article)) 2140 (stringp article))
2014 ;; Hooks for getting information from the article. 2141 ;; Hooks for getting information from the article.
2015 ;; This hook must be called before being narrowed. 2142 ;; This hook must be called before being narrowed.
2016 (let (buffer-read-only) 2143 (let (buffer-read-only)
2017 (run-hooks 'internal-hook) 2144 (gnus-run-hooks 'gnus-tmp-internal-hook)
2018 (run-hooks 'gnus-article-prepare-hook) 2145 (gnus-run-hooks 'gnus-article-prepare-hook)
2019 ;; Decode MIME message. 2146 ;; Decode MIME message.
2020 (if gnus-show-mime 2147 (if gnus-show-mime
2021 (if (or (not gnus-strict-mime) 2148 (if (or (not gnus-strict-mime)
2022 (gnus-fetch-field "Mime-Version")) 2149 (gnus-fetch-field "Mime-Version"))
2023 (funcall gnus-show-mime-method) 2150 (let ((coding-system-for-write 'binary)
2024 (funcall gnus-decode-encoded-word-method)) 2151 (coding-system-for-read 'binary))
2025 (funcall gnus-show-traditional-method)) 2152 (funcall gnus-show-mime-method))
2153 (funcall gnus-decode-encoded-word-method))
2154 (funcall gnus-show-traditional-method))
2026 ;; Perform the article display hooks. 2155 ;; Perform the article display hooks.
2027 (run-hooks 'gnus-article-display-hook)) 2156 (gnus-run-hooks 'gnus-article-display-hook))
2028 ;; Do page break. 2157 ;; Do page break.
2029 (goto-char (point-min)) 2158 (goto-char (point-min))
2030 (setq gnus-page-broken 2159 (setq gnus-page-broken
@@ -2034,6 +2163,8 @@ If ALL-HEADERS is non-nil, no headers are hidden."
2034 (gnus-set-mode-line 'article) 2163 (gnus-set-mode-line 'article)
2035 (gnus-configure-windows 'article) 2164 (gnus-configure-windows 'article)
2036 (goto-char (point-min)) 2165 (goto-char (point-min))
2166 (search-forward "\n\n" nil t)
2167 (set-window-point (get-buffer-window (current-buffer)) (point))
2037 t)))))) 2168 t))))))
2038 2169
2039(defun gnus-article-wash-status () 2170(defun gnus-article-wash-status ()
@@ -2058,7 +2189,9 @@ If ALL-HEADERS is non-nil, no headers are hidden."
2058 (if mime ?m ? ) 2189 (if mime ?m ? )
2059 (if emphasis ?e ? ))))) 2190 (if emphasis ?e ? )))))
2060 2191
2061(defun gnus-article-hide-headers-if-wanted () 2192(fset 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers)
2193
2194(defun gnus-article-maybe-hide-headers ()
2062 "Hide unwanted headers if `gnus-have-all-headers' is nil. 2195 "Hide unwanted headers if `gnus-have-all-headers' is nil.
2063Provided for backwards compatibility." 2196Provided for backwards compatibility."
2064 (or (save-excursion (set-buffer gnus-summary-buffer) gnus-have-all-headers) 2197 (or (save-excursion (set-buffer gnus-summary-buffer) gnus-have-all-headers)
@@ -2198,7 +2331,8 @@ Argument LINES specifies lines to be scrolled down."
2198 (error "There is no summary buffer for this article buffer") 2331 (error "There is no summary buffer for this article buffer")
2199 (gnus-article-set-globals) 2332 (gnus-article-set-globals)
2200 (gnus-configure-windows 'article) 2333 (gnus-configure-windows 'article)
2201 (gnus-summary-goto-subject gnus-current-article))) 2334 (gnus-summary-goto-subject gnus-current-article)
2335 (gnus-summary-position-point)))
2202 2336
2203(defun gnus-article-describe-briefly () 2337(defun gnus-article-describe-briefly ()
2204 "Describe article mode commands briefly." 2338 "Describe article mode commands briefly."
@@ -2212,7 +2346,7 @@ Argument LINES specifies lines to be scrolled down."
2212 (let ((obuf (current-buffer)) 2346 (let ((obuf (current-buffer))
2213 (owin (current-window-configuration)) 2347 (owin (current-window-configuration))
2214 func) 2348 func)
2215 (switch-to-buffer gnus-summary-buffer 'norecord) 2349 (switch-to-buffer gnus-article-current-summary 'norecord)
2216 (setq func (lookup-key (current-local-map) (this-command-keys))) 2350 (setq func (lookup-key (current-local-map) (this-command-keys)))
2217 (call-interactively func) 2351 (call-interactively func)
2218 (set-buffer obuf) 2352 (set-buffer obuf)
@@ -2223,7 +2357,7 @@ Argument LINES specifies lines to be scrolled down."
2223 "Execute the last keystroke in the summary buffer." 2357 "Execute the last keystroke in the summary buffer."
2224 (interactive) 2358 (interactive)
2225 (let (func) 2359 (let (func)
2226 (pop-to-buffer gnus-summary-buffer 'norecord) 2360 (pop-to-buffer gnus-article-current-summary 'norecord)
2227 (setq func (lookup-key (current-local-map) (this-command-keys))) 2361 (setq func (lookup-key (current-local-map) (this-command-keys)))
2228 (call-interactively func))) 2362 (call-interactively func)))
2229 2363
@@ -2231,85 +2365,101 @@ Argument LINES specifies lines to be scrolled down."
2231 "Read a summary buffer key sequence and execute it from the article buffer." 2365 "Read a summary buffer key sequence and execute it from the article buffer."
2232 (interactive "P") 2366 (interactive "P")
2233 (let ((nosaves 2367 (let ((nosaves
2234 '("q" "Q" "c" "r" "R" "\C-c\C-f" "m" "a" "f" "F" 2368 '("q" "Q" "c" "r" "R" "\C-c\C-f" "m" "a" "f" "F"
2235 "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP" 2369 "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"
2236 "=" "^" "\M-^" "|")) 2370 "=" "^" "\M-^" "|"))
2237 (nosave-but-article 2371 (nosave-but-article
2238 '("A\r")) 2372 '("A\r"))
2239 (nosave-in-article 2373 (nosave-in-article
2240 '("\C-d")) 2374 '("\C-d"))
2241 keys) 2375 (up-to-top
2376 '("n" "Gn" "p" "Gp"))
2377 keys new-sum-point)
2242 (save-excursion 2378 (save-excursion
2243 (set-buffer gnus-summary-buffer) 2379 (set-buffer gnus-article-current-summary)
2244 (let (gnus-pick-mode) 2380 (let (gnus-pick-mode)
2245 (push (or key last-command-event) unread-command-events) 2381 (push (or key last-command-event) unread-command-events)
2246 (setq keys (read-key-sequence nil)))) 2382 (setq keys (read-key-sequence nil))))
2247 (message "") 2383 (message "")
2248 2384
2249 (if (or (member keys nosaves) 2385 (if (or (member keys nosaves)
2250 (member keys nosave-but-article) 2386 (member keys nosave-but-article)
2251 (member keys nosave-in-article)) 2387 (member keys nosave-in-article))
2252 (let (func) 2388 (let (func)
2253 (save-window-excursion 2389 (save-window-excursion
2254 (pop-to-buffer gnus-summary-buffer 'norecord) 2390 (pop-to-buffer gnus-article-current-summary 'norecord)
2255 ;; We disable the pick minor mode commands. 2391 ;; We disable the pick minor mode commands.
2256 (let (gnus-pick-mode) 2392 (let (gnus-pick-mode)
2257 (setq func (lookup-key (current-local-map) keys)))) 2393 (setq func (lookup-key (current-local-map) keys))))
2258 (if (not func) 2394 (if (not func)
2259 (ding) 2395 (ding)
2260 (unless (member keys nosave-in-article) 2396 (unless (member keys nosave-in-article)
2261 (set-buffer gnus-summary-buffer)) 2397 (set-buffer gnus-article-current-summary))
2262 (call-interactively func)) 2398 (call-interactively func)
2263 (when (member keys nosave-but-article) 2399 (setq new-sum-point (point)))
2264 (pop-to-buffer gnus-article-buffer 'norecord))) 2400 (when (member keys nosave-but-article)
2401 (pop-to-buffer gnus-article-buffer 'norecord)))
2265 ;; These commands should restore window configuration. 2402 ;; These commands should restore window configuration.
2266 (let ((obuf (current-buffer)) 2403 (let ((obuf (current-buffer))
2267 (owin (current-window-configuration)) 2404 (owin (current-window-configuration))
2268 (opoint (point)) 2405 (opoint (point))
2269 func in-buffer) 2406 (summary gnus-article-current-summary)
2270 (if not-restore-window 2407 func in-buffer selected)
2271 (pop-to-buffer gnus-summary-buffer 'norecord) 2408 (if not-restore-window
2272 (switch-to-buffer gnus-summary-buffer 'norecord)) 2409 (pop-to-buffer summary 'norecord)
2273 (setq in-buffer (current-buffer)) 2410 (switch-to-buffer summary 'norecord))
2274 ;; We disable the pick minor mode commands. 2411 (setq in-buffer (current-buffer))
2275 (if (setq func (let (gnus-pick-mode) 2412 ;; We disable the pick minor mode commands.
2276 (lookup-key (current-local-map) keys))) 2413 (if (setq func (let (gnus-pick-mode)
2277 (call-interactively func) 2414 (lookup-key (current-local-map) keys)))
2278 (ding)) 2415 (progn
2279 (when (eq in-buffer (current-buffer)) 2416 (call-interactively func)
2280 (set-buffer obuf) 2417 (setq new-sum-point (point)))
2281 (unless not-restore-window 2418 (ding))
2282 (set-window-configuration owin)) 2419 (when (eq in-buffer (current-buffer))
2283 (set-window-point (get-buffer-window (current-buffer)) opoint)))))) 2420 (setq selected (gnus-summary-select-article))
2421 (set-buffer obuf)
2422 (unless not-restore-window
2423 (set-window-configuration owin))
2424 (unless (or (not (eq selected 'old)) (member keys up-to-top))
2425 (set-window-point (get-buffer-window (current-buffer))
2426 opoint))
2427 (let ((win (get-buffer-window gnus-article-current-summary)))
2428 (when win
2429 (set-window-point win new-sum-point))))))))
2284 2430
2285(defun gnus-article-hide (&optional arg force) 2431(defun gnus-article-hide (&optional arg force)
2286 "Hide all the gruft in the current article. 2432 "Hide all the gruft in the current article.
2287This means that PGP stuff, signatures, cited text and (some) 2433This means that PGP stuff, signatures, cited text and (some)
2288headers will be hidden. 2434headers will be hidden.
2289If given a prefix, show the hidden text instead." 2435If given a prefix, show the hidden text instead."
2290 (interactive (list current-prefix-arg 'force)) 2436 (interactive (append (gnus-article-hidden-arg) (list 'force)))
2291 (gnus-article-hide-headers arg) 2437 (gnus-article-hide-headers arg)
2292 (gnus-article-hide-pgp arg) 2438 (gnus-article-hide-pgp arg)
2293 (gnus-article-hide-citation-maybe arg force) 2439 (gnus-article-hide-citation-maybe arg force)
2294 (gnus-article-hide-signature arg)) 2440 (gnus-article-hide-signature arg))
2295 2441
2296(defun gnus-article-maybe-highlight () 2442(defun gnus-article-maybe-highlight ()
2297 "Do some article highlighting if `article-visual' is non-nil." 2443 "Do some article highlighting if article highlighting is requested."
2298 (when (gnus-visual-p 'article-highlight 'highlight) 2444 (when (gnus-visual-p 'article-highlight 'highlight)
2299 (gnus-article-highlight-some))) 2445 (gnus-article-highlight-some)))
2300 2446
2447(defun gnus-check-group-server ()
2448 ;; Make sure the connection to the server is alive.
2449 (unless (gnus-server-opened
2450 (gnus-find-method-for-group gnus-newsgroup-name))
2451 (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name))
2452 (gnus-request-group gnus-newsgroup-name t)))
2453
2301(defun gnus-request-article-this-buffer (article group) 2454(defun gnus-request-article-this-buffer (article group)
2302 "Get an article and insert it into this buffer." 2455 "Get an article and insert it into this buffer."
2303 (let (do-update-line) 2456 (let (do-update-line sparse-header)
2304 (prog1 2457 (prog1
2305 (save-excursion 2458 (save-excursion
2306 (erase-buffer) 2459 (erase-buffer)
2307 (gnus-kill-all-overlays) 2460 (gnus-kill-all-overlays)
2308 (setq group (or group gnus-newsgroup-name)) 2461 (setq group (or group gnus-newsgroup-name))
2309 2462
2310 ;; Open server if it has closed.
2311 (gnus-check-server (gnus-find-method-for-group group))
2312
2313 ;; Using `gnus-request-article' directly will insert the article into 2463 ;; Using `gnus-request-article' directly will insert the article into
2314 ;; `nntp-server-buffer' - so we'll save some time by not having to 2464 ;; `nntp-server-buffer' - so we'll save some time by not having to
2315 ;; copy it from the server buffer into the article buffer. 2465 ;; copy it from the server buffer into the article buffer.
@@ -2326,7 +2476,7 @@ If given a prefix, show the hidden text instead."
2326 (when (and (numberp article) 2476 (when (and (numberp article)
2327 gnus-summary-buffer 2477 gnus-summary-buffer
2328 (get-buffer gnus-summary-buffer) 2478 (get-buffer gnus-summary-buffer)
2329 (buffer-name (get-buffer gnus-summary-buffer))) 2479 (gnus-buffer-exists-p gnus-summary-buffer))
2330 (save-excursion 2480 (save-excursion
2331 (set-buffer gnus-summary-buffer) 2481 (set-buffer gnus-summary-buffer)
2332 (let ((header (gnus-summary-article-header article))) 2482 (let ((header (gnus-summary-article-header article)))
@@ -2337,7 +2487,7 @@ If given a prefix, show the hidden text instead."
2337 (setq do-update-line article) 2487 (setq do-update-line article)
2338 (setq article (mail-header-id header)) 2488 (setq article (mail-header-id header))
2339 (let ((gnus-override-method gnus-refer-article-method)) 2489 (let ((gnus-override-method gnus-refer-article-method))
2340 (gnus-read-header article)) 2490 (setq sparse-header (gnus-read-header article)))
2341 (setq gnus-newsgroup-sparse 2491 (setq gnus-newsgroup-sparse
2342 (delq article gnus-newsgroup-sparse))) 2492 (delq article gnus-newsgroup-sparse)))
2343 ((vectorp header) 2493 ((vectorp header)
@@ -2350,10 +2500,13 @@ If given a prefix, show the hidden text instead."
2350 2500
2351 (let ((method (gnus-find-method-for-group 2501 (let ((method (gnus-find-method-for-group
2352 gnus-newsgroup-name))) 2502 gnus-newsgroup-name)))
2353 (if (not (eq (car method) 'nneething)) 2503 (when (and (eq (car method) 'nneething)
2354 () 2504 (vectorp header))
2355 (let ((dir (concat (file-name-as-directory (nth 1 method)) 2505 (let ((dir (concat
2356 (mail-header-subject header)))) 2506 (file-name-as-directory
2507 (or (cadr (assq 'nneething-address method))
2508 (nth 1 method)))
2509 (mail-header-subject header))))
2357 (when (file-directory-p dir) 2510 (when (file-directory-p dir)
2358 (setq article 'nneething) 2511 (setq article 'nneething)
2359 (gnus-group-enter-directory dir)))))))) 2512 (gnus-group-enter-directory dir))))))))
@@ -2363,7 +2516,7 @@ If given a prefix, show the hidden text instead."
2363 ((and (numberp article) 2516 ((and (numberp article)
2364 gnus-summary-buffer 2517 gnus-summary-buffer
2365 (get-buffer gnus-summary-buffer) 2518 (get-buffer gnus-summary-buffer)
2366 (buffer-name (get-buffer gnus-summary-buffer)) 2519 (gnus-buffer-exists-p gnus-summary-buffer)
2367 (eq (cdr (save-excursion 2520 (eq (cdr (save-excursion
2368 (set-buffer gnus-summary-buffer) 2521 (set-buffer gnus-summary-buffer)
2369 (assq article gnus-newsgroup-reads))) 2522 (assq article gnus-newsgroup-reads)))
@@ -2385,6 +2538,8 @@ If given a prefix, show the hidden text instead."
2385 ;; Check asynchronous pre-fetch. 2538 ;; Check asynchronous pre-fetch.
2386 ((gnus-async-request-fetched-article group article (current-buffer)) 2539 ((gnus-async-request-fetched-article group article (current-buffer))
2387 (gnus-async-prefetch-next group article gnus-summary-buffer) 2540 (gnus-async-prefetch-next group article gnus-summary-buffer)
2541 (when (and (numberp article) gnus-keep-backlog)
2542 (gnus-backlog-enter-article group article (current-buffer)))
2388 'article) 2543 'article)
2389 ;; Check the cache. 2544 ;; Check the cache.
2390 ((and gnus-use-cache 2545 ((and gnus-use-cache
@@ -2398,6 +2553,7 @@ If given a prefix, show the hidden text instead."
2398 (buffer-read-only nil)) 2553 (buffer-read-only nil))
2399 (erase-buffer) 2554 (erase-buffer)
2400 (gnus-kill-all-overlays) 2555 (gnus-kill-all-overlays)
2556 (gnus-check-group-server)
2401 (when (gnus-request-article article group (current-buffer)) 2557 (when (gnus-request-article article group (current-buffer))
2402 (when (numberp article) 2558 (when (numberp article)
2403 (gnus-async-prefetch-next group article gnus-summary-buffer) 2559 (gnus-async-prefetch-next group article gnus-summary-buffer)
@@ -2408,20 +2564,21 @@ If given a prefix, show the hidden text instead."
2408 ;; It was a pseudo. 2564 ;; It was a pseudo.
2409 (t article))) 2565 (t article)))
2410 2566
2567 ;; Associate this article with the current summary buffer.
2568 (setq gnus-article-current-summary gnus-summary-buffer)
2569
2411 ;; Take the article from the original article buffer 2570 ;; Take the article from the original article buffer
2412 ;; and place it in the buffer it's supposed to be in. 2571 ;; and place it in the buffer it's supposed to be in.
2413 (when (and (get-buffer gnus-article-buffer) 2572 (when (and (get-buffer gnus-article-buffer)
2414 ;;(numberp article)
2415 (equal (buffer-name (current-buffer)) 2573 (equal (buffer-name (current-buffer))
2416 (buffer-name (get-buffer gnus-article-buffer)))) 2574 (buffer-name (get-buffer gnus-article-buffer))))
2417 (save-excursion 2575 (save-excursion
2418 (if (get-buffer gnus-original-article-buffer) 2576 (if (get-buffer gnus-original-article-buffer)
2419 (set-buffer (get-buffer gnus-original-article-buffer)) 2577 (set-buffer gnus-original-article-buffer)
2420 (set-buffer (get-buffer-create gnus-original-article-buffer)) 2578 (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
2421 (buffer-disable-undo (current-buffer)) 2579 (buffer-disable-undo (current-buffer))
2422 (setq major-mode 'gnus-original-article-mode) 2580 (setq major-mode 'gnus-original-article-mode)
2423 (setq buffer-read-only t) 2581 (setq buffer-read-only t))
2424 (gnus-add-current-to-buffer-list))
2425 (let (buffer-read-only) 2582 (let (buffer-read-only)
2426 (erase-buffer) 2583 (erase-buffer)
2427 (insert-buffer-substring gnus-article-buffer)) 2584 (insert-buffer-substring gnus-article-buffer))
@@ -2433,7 +2590,7 @@ If given a prefix, show the hidden text instead."
2433 (stringp article))) 2590 (stringp article)))
2434 (let ((buf (current-buffer))) 2591 (let ((buf (current-buffer)))
2435 (set-buffer gnus-summary-buffer) 2592 (set-buffer gnus-summary-buffer)
2436 (gnus-summary-update-article do-update-line) 2593 (gnus-summary-update-article do-update-line sparse-header)
2437 (gnus-summary-goto-subject do-update-line nil t) 2594 (gnus-summary-goto-subject do-update-line nil t)
2438 (set-window-point (get-buffer-window (current-buffer) t) 2595 (set-window-point (get-buffer-window (current-buffer) t)
2439 (point)) 2596 (point))
@@ -2469,7 +2626,6 @@ This is an extended text-mode.
2469 2626
2470\\{gnus-article-edit-mode-map}" 2627\\{gnus-article-edit-mode-map}"
2471 (interactive) 2628 (interactive)
2472 (kill-all-local-variables)
2473 (setq major-mode 'gnus-article-edit-mode) 2629 (setq major-mode 'gnus-article-edit-mode)
2474 (setq mode-name "Article Edit") 2630 (setq mode-name "Article Edit")
2475 (use-local-map gnus-article-edit-mode-map) 2631 (use-local-map gnus-article-edit-mode-map)
@@ -2478,7 +2634,7 @@ This is an extended text-mode.
2478 (setq buffer-read-only nil) 2634 (setq buffer-read-only nil)
2479 (buffer-enable-undo) 2635 (buffer-enable-undo)
2480 (widen) 2636 (widen)
2481 (run-hooks 'text-mode 'gnus-article-edit-mode-hook)) 2637 (gnus-run-hooks 'text-mode-hook 'gnus-article-edit-mode-hook))
2482 2638
2483(defun gnus-article-edit (&optional force) 2639(defun gnus-article-edit (&optional force)
2484 "Edit the current article. 2640 "Edit the current article.
@@ -2489,26 +2645,50 @@ groups."
2489 (when (and (not force) 2645 (when (and (not force)
2490 (gnus-group-read-only-p)) 2646 (gnus-group-read-only-p))
2491 (error "The current newsgroup does not support article editing")) 2647 (error "The current newsgroup does not support article editing"))
2648 (gnus-article-date-original)
2492 (gnus-article-edit-article 2649 (gnus-article-edit-article
2493 `(lambda () 2650 `(lambda (no-highlight)
2494 (gnus-summary-edit-article-done 2651 (gnus-summary-edit-article-done
2495 ,(or (mail-header-references gnus-current-headers) "") 2652 ,(or (mail-header-references gnus-current-headers) "")
2496 ,(gnus-group-read-only-p) ,gnus-summary-buffer)))) 2653 ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight))))
2497 2654
2498(defun gnus-article-edit-article (exit-func) 2655(defun gnus-article-edit-article (exit-func)
2499 "Start editing the contents of the current article buffer." 2656 "Start editing the contents of the current article buffer."
2500 (let ((winconf (current-window-configuration))) 2657 (let ((winconf (current-window-configuration)))
2501 (set-buffer gnus-article-buffer) 2658 (set-buffer gnus-article-buffer)
2502 (gnus-article-edit-mode) 2659 (gnus-article-edit-mode)
2660 (gnus-article-delete-text-of-type 'annotation)
2503 (gnus-set-text-properties (point-min) (point-max) nil) 2661 (gnus-set-text-properties (point-min) (point-max) nil)
2504 (gnus-configure-windows 'edit-article) 2662 (gnus-configure-windows 'edit-article)
2505 (setq gnus-article-edit-done-function exit-func) 2663 (setq gnus-article-edit-done-function exit-func)
2506 (setq gnus-prev-winconf winconf) 2664 (setq gnus-prev-winconf winconf)
2507 (gnus-message 6 "C-c C-c to end edits"))) 2665 (gnus-message 6 "C-c C-c to end edits")))
2508 2666
2509(defun gnus-article-edit-done () 2667(defun gnus-article-edit-done (&optional arg)
2510 "Update the article edits and exit." 2668 "Update the article edits and exit."
2511 (interactive) 2669 (interactive "P")
2670 (save-excursion
2671 (save-restriction
2672 (widen)
2673 (goto-char (point-min))
2674 (when (search-forward "\n\n" nil 1)
2675 (let ((lines (count-lines (point) (point-max)))
2676 (length (- (point-max) (point)))
2677 (case-fold-search t)
2678 (body (copy-marker (point))))
2679 (goto-char (point-min))
2680 (when (re-search-forward "^content-length:[ \t]\\([0-9]+\\)" body t)
2681 (delete-region (match-beginning 1) (match-end 1))
2682 (insert (number-to-string length)))
2683 (goto-char (point-min))
2684 (when (re-search-forward
2685 "^x-content-length:[ \t]\\([0-9]+\\)" body t)
2686 (delete-region (match-beginning 1) (match-end 1))
2687 (insert (number-to-string length)))
2688 (goto-char (point-min))
2689 (when (re-search-forward "^lines:[ \t]\\([0-9]+\\)" body t)
2690 (delete-region (match-beginning 1) (match-end 1))
2691 (insert (number-to-string lines)))))))
2512 (let ((func gnus-article-edit-done-function) 2692 (let ((func gnus-article-edit-done-function)
2513 (buf (current-buffer)) 2693 (buf (current-buffer))
2514 (start (window-start))) 2694 (start (window-start)))
@@ -2516,7 +2696,7 @@ groups."
2516 (save-excursion 2696 (save-excursion
2517 (set-buffer buf) 2697 (set-buffer buf)
2518 (let ((buffer-read-only nil)) 2698 (let ((buffer-read-only nil))
2519 (funcall func))) 2699 (funcall func arg)))
2520 (set-buffer buf) 2700 (set-buffer buf)
2521 (set-window-start (get-buffer-window buf) start) 2701 (set-window-start (get-buffer-window buf) start)
2522 (set-window-point (get-buffer-window buf) (point)))) 2702 (set-window-point (get-buffer-window buf) (point))))
@@ -2576,21 +2756,23 @@ groups."
2576 :type 'regexp) 2756 :type 'regexp)
2577 2757
2578(defcustom gnus-button-alist 2758(defcustom gnus-button-alist
2579 `(("<\\(url: ?\\)?news:\\([^>\n\t ]*@[^>\n\t ]*\\)>" 0 t 2759 `(("<\\(url:[>\n\t ]*?\\)?news:[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>" 0 t
2580 gnus-button-message-id 2) 2760 gnus-button-message-id 2)
2581 ("\\bnews:\\([^>\n\t ]*@[^>\n\t ]*\\)" 0 t gnus-button-message-id 1) 2761 ("\\bnews:\\([^>\n\t ]*@[^>\n\t ]*\\)" 0 t gnus-button-message-id 1)
2582 ("\\(\\b<\\(url: ?\\)?news:\\(//\\)?\\([^>\n\t ]*\\)>\\)" 1 t 2762 ("\\(\\b<\\(url:[>\n\t ]*\\)?news:[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)"
2763 1 t
2583 gnus-button-fetch-group 4) 2764 gnus-button-fetch-group 4)
2584 ("\\bnews:\\(//\\)?\\([^>\n\t ]+\\)" 0 t gnus-button-fetch-group 2) 2765 ("\\bnews:\\(//\\)?\\([^'\">\n\t ]+\\)" 0 t gnus-button-fetch-group 2)
2585 ("\\bin\\( +article\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2 2766 ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2
2586 t gnus-button-message-id 3) 2767 t gnus-button-message-id 3)
2587 ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>" 0 t gnus-url-mailto 2) 2768 ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>" 0 t gnus-url-mailto 2)
2769 ("mailto:\\([a-zA-Z.-@_+0-9%]+\\)" 0 t gnus-url-mailto 1)
2588 ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1) 2770 ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1)
2589 ;; This is how URLs _should_ be embedded in text... 2771 ;; This is how URLs _should_ be embedded in text...
2590 ("<URL: *\\([^>]*\\)>" 0 t gnus-button-embedded-url 1) 2772 ("<URL: *\\([^>]*\\)>" 0 t gnus-button-embedded-url 1)
2591 ;; Raw URLs. 2773 ;; Raw URLs.
2592 (,gnus-button-url-regexp 0 t gnus-button-url 0)) 2774 (,gnus-button-url-regexp 0 t gnus-button-url 0))
2593 "Alist of regexps matching buttons in article bodies. 2775 "*Alist of regexps matching buttons in article bodies.
2594 2776
2595Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where 2777Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where
2596REGEXP: is the string matching text around the button, 2778REGEXP: is the string matching text around the button,
@@ -2622,7 +2804,7 @@ variable it the real callback function."
2622 ("^[^:]+:" ,gnus-button-url-regexp 0 t gnus-button-url 0) 2804 ("^[^:]+:" ,gnus-button-url-regexp 0 t gnus-button-url 0)
2623 ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t 2805 ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t
2624 gnus-button-message-id 3)) 2806 gnus-button-message-id 3))
2625 "Alist of headers and regexps to match buttons in article heads. 2807 "*Alist of headers and regexps to match buttons in article heads.
2626 2808
2627This alist is very similar to `gnus-button-alist', except that each 2809This alist is very similar to `gnus-button-alist', except that each
2628alist has an additional HEADER element first in each entry: 2810alist has an additional HEADER element first in each entry:
@@ -2660,6 +2842,7 @@ call it with the value of the `gnus-data' text property."
2660 (let* ((pos (posn-point (event-start event))) 2842 (let* ((pos (posn-point (event-start event)))
2661 (data (get-text-property pos 'gnus-data)) 2843 (data (get-text-property pos 'gnus-data))
2662 (fun (get-text-property pos 'gnus-callback))) 2844 (fun (get-text-property pos 'gnus-callback)))
2845 (goto-char pos)
2663 (when fun 2846 (when fun
2664 (funcall fun data)))) 2847 (funcall fun data))))
2665 2848
@@ -2964,14 +3147,6 @@ specified by `gnus-button-alist'."
2964 (match-string 3 address) 3147 (match-string 3 address)
2965 "nntp"))))))) 3148 "nntp")))))))
2966 3149
2967(defun gnus-split-string (string pattern)
2968 "Return a list of substrings of STRING which are separated by PATTERN."
2969 (let (parts (start 0))
2970 (while (string-match pattern string start)
2971 (setq parts (cons (substring string start (match-beginning 0)) parts)
2972 start (match-end 0)))
2973 (nreverse (cons (substring string start) parts))))
2974
2975(defun gnus-url-parse-query-string (query &optional downcase) 3150(defun gnus-url-parse-query-string (query &optional downcase)
2976 (let (retval pairs cur key val) 3151 (let (retval pairs cur key val)
2977 (setq pairs (gnus-split-string query "&")) 3152 (setq pairs (gnus-split-string query "&"))
@@ -3026,7 +3201,7 @@ forbidden in URL encoding."
3026 ;; Send mail to someone 3201 ;; Send mail to someone
3027 (when (string-match "mailto:/*\\(.*\\)" url) 3202 (when (string-match "mailto:/*\\(.*\\)" url)
3028 (setq url (substring url (match-beginning 1) nil))) 3203 (setq url (substring url (match-beginning 1) nil)))
3029 (let (to args source-url subject func) 3204 (let (to args subject func)
3030 (if (string-match (regexp-quote "?") url) 3205 (if (string-match (regexp-quote "?") url)
3031 (setq to (gnus-url-unhex-string (substring url 0 (match-beginning 0))) 3206 (setq to (gnus-url-unhex-string (substring url 0 (match-beginning 0)))
3032 args (gnus-url-parse-query-string 3207 args (gnus-url-parse-query-string
@@ -3061,6 +3236,7 @@ forbidden in URL encoding."
3061 3236
3062(defun gnus-button-embedded-url (address) 3237(defun gnus-button-embedded-url (address)
3063 "Browse ADDRESS." 3238 "Browse ADDRESS."
3239 ;; In Emacs 20, `browse-url-browser-function' may be an alist.
3064 (browse-url (gnus-strip-whitespace address))) 3240 (browse-url (gnus-strip-whitespace address)))
3065 3241
3066;;; Next/prev buttons in the article buffer. 3242;;; Next/prev buttons in the article buffer.
@@ -3079,7 +3255,8 @@ forbidden in URL encoding."
3079 (gnus-eval-format 3255 (gnus-eval-format
3080 gnus-prev-page-line-format nil 3256 gnus-prev-page-line-format nil
3081 `(gnus-prev t local-map ,gnus-prev-page-map 3257 `(gnus-prev t local-map ,gnus-prev-page-map
3082 gnus-callback gnus-article-button-prev-page)))) 3258 gnus-callback gnus-article-button-prev-page
3259 gnus-type annotation))))
3083 3260
3084(defvar gnus-next-page-map nil) 3261(defvar gnus-next-page-map nil)
3085(unless gnus-next-page-map 3262(unless gnus-next-page-map
@@ -3107,9 +3284,10 @@ forbidden in URL encoding."
3107(defun gnus-insert-next-page-button () 3284(defun gnus-insert-next-page-button ()
3108 (let ((buffer-read-only nil)) 3285 (let ((buffer-read-only nil))
3109 (gnus-eval-format gnus-next-page-line-format nil 3286 (gnus-eval-format gnus-next-page-line-format nil
3110 `(gnus-next t local-map ,gnus-next-page-map 3287 `(gnus-next
3111 gnus-callback 3288 t local-map ,gnus-next-page-map
3112 gnus-article-button-next-page)))) 3289 gnus-callback gnus-article-button-next-page
3290 gnus-type annotation))))
3113 3291
3114(defun gnus-article-button-next-page (arg) 3292(defun gnus-article-button-next-page (arg)
3115 "Go to the next page." 3293 "Go to the next page."
diff --git a/lisp/gnus/gnus-async.el b/lisp/gnus/gnus-async.el
index 5c8a5bf1b71..01d02a59cf6 100644
--- a/lisp/gnus/gnus-async.el
+++ b/lisp/gnus/gnus-async.el
@@ -1,7 +1,7 @@
1;;; gnus-async.el --- asynchronous support for Gnus 1;;; gnus-async.el --- asynchronous support for Gnus
2;; Copyright (C) 1996,97 Free Software Foundation, Inc. 2;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: news 5;; Keywords: news
6 6
7;; This file is part of GNU Emacs. 7;; This file is part of GNU Emacs.
@@ -27,6 +27,8 @@
27 27
28(eval-when-compile (require 'cl)) 28(eval-when-compile (require 'cl))
29 29
30(eval-when-compile (require 'cl))
31
30(require 'gnus) 32(require 'gnus)
31(require 'gnus-sum) 33(require 'gnus-sum)
32(require 'nntp) 34(require 'nntp)
@@ -77,6 +79,7 @@ It should return non-nil if the article is to be prefetched."
77(defvar gnus-async-article-alist nil) 79(defvar gnus-async-article-alist nil)
78(defvar gnus-async-article-semaphore '(nil)) 80(defvar gnus-async-article-semaphore '(nil))
79(defvar gnus-async-fetch-list nil) 81(defvar gnus-async-fetch-list nil)
82(defvar gnus-asynch-obarray nil)
80 83
81(defvar gnus-async-prefetch-headers-buffer " *Async Prefetch Headers*") 84(defvar gnus-async-prefetch-headers-buffer " *Async Prefetch Headers*")
82(defvar gnus-async-header-prefetched nil) 85(defvar gnus-async-header-prefetched nil)
@@ -120,7 +123,10 @@ It should return non-nil if the article is to be prefetched."
120 gnus-async-header-prefetched nil)) 123 gnus-async-header-prefetched nil))
121 124
122(defun gnus-async-set-buffer () 125(defun gnus-async-set-buffer ()
123 (nnheader-set-temp-buffer gnus-async-prefetch-article-buffer t)) 126 (nnheader-set-temp-buffer gnus-async-prefetch-article-buffer t)
127 (unless gnus-asynch-obarray
128 (set (make-local-variable 'gnus-asynch-obarray)
129 (gnus-make-hashtable 1023))))
124 130
125(defun gnus-async-halt-prefetch () 131(defun gnus-async-halt-prefetch ()
126 "Stop prefetching." 132 "Stop prefetching."
@@ -209,10 +215,13 @@ It should return non-nil if the article is to be prefetched."
209 (when arg 215 (when arg
210 (gnus-async-set-buffer) 216 (gnus-async-set-buffer)
211 (gnus-async-with-semaphore 217 (gnus-async-with-semaphore
212 (push (list ',(intern (format "%s-%d" group article)) 218 (setq
213 ,mark (set-marker (make-marker) (point-max)) 219 gnus-async-article-alist
214 ,group ,article) 220 (cons (list ',(intern (format "%s-%d" group article)
215 gnus-async-article-alist))) 221 gnus-asynch-obarray)
222 ,mark (set-marker (make-marker) (point-max))
223 ,group ,article)
224 gnus-async-article-alist))))
216 (if (not (gnus-buffer-live-p ,summary)) 225 (if (not (gnus-buffer-live-p ,summary))
217 (gnus-async-with-semaphore 226 (gnus-async-with-semaphore
218 (setq gnus-async-fetch-list nil)) 227 (setq gnus-async-fetch-list nil))
@@ -259,8 +268,11 @@ It should return non-nil if the article is to be prefetched."
259 268
260(defun gnus-async-prefetched-article-entry (group article) 269(defun gnus-async-prefetched-article-entry (group article)
261 "Return the entry for ARTICLE in GROUP iff it has been prefetched." 270 "Return the entry for ARTICLE in GROUP iff it has been prefetched."
262 (let ((entry (assq (intern (format "%s-%d" group article)) 271 (let ((entry (save-excursion
263 gnus-async-article-alist))) 272 (gnus-async-set-buffer)
273 (assq (intern (format "%s-%d" group article)
274 gnus-asynch-obarray)
275 gnus-async-article-alist))))
264 ;; Perhaps something has emptied the buffer? 276 ;; Perhaps something has emptied the buffer?
265 (if (and entry 277 (if (and entry
266 (= (cadr entry) (caddr entry))) 278 (= (cadr entry) (caddr entry)))
diff --git a/lisp/gnus/gnus-audio.el b/lisp/gnus/gnus-audio.el
index e72804a3bc6..f3bb686d8c9 100644
--- a/lisp/gnus/gnus-audio.el
+++ b/lisp/gnus/gnus-audio.el
@@ -2,7 +2,6 @@
2;; Copyright (C) 1996 Free Software Foundation 2;; Copyright (C) 1996 Free Software Foundation
3 3
4;; Author: Steven L. Baur <steve@miranova.com> 4;; Author: Steven L. Baur <steve@miranova.com>
5;; Keywords: news
6 5
7;; This file is part of GNU Emacs. 6;; This file is part of GNU Emacs.
8 7
@@ -42,12 +41,12 @@
42 "The directory containing the Sound Files.") 41 "The directory containing the Sound Files.")
43 42
44(defvar gnus-audio-au-player "/usr/bin/showaudio" 43(defvar gnus-audio-au-player "/usr/bin/showaudio"
45 "Executable program for playing sun AU format sound files") 44 "Executable program for playing sun AU format sound files.")
46(defvar gnus-audio-wav-player "/usr/local/bin/play"
47 "Executable program for playing WAV files")
48 45
46(defvar gnus-audio-wav-player "/usr/local/bin/play"
47 "Executable program for playing WAV files.")
49 48
50;;; The following isn't implemented yet. Wait for Red Gnus. 49;;; The following isn't implemented yet. Wait for Millennium Gnus.
51;(defvar gnus-audio-effects-enabled t 50;(defvar gnus-audio-effects-enabled t
52; "When t, Gnus will use sound effects.") 51; "When t, Gnus will use sound effects.")
53;(defvar gnus-audio-enable-hooks nil 52;(defvar gnus-audio-enable-hooks nil
@@ -71,14 +70,14 @@
71; "Enable Sound Effects for Gnus." 70; "Enable Sound Effects for Gnus."
72; (interactive) 71; (interactive)
73; (setq gnus-audio-effects-enabled t) 72; (setq gnus-audio-effects-enabled t)
74; (run-hooks gnus-audio-enable-hooks)) 73; (gnus-run-hooks gnus-audio-enable-hooks))
75 74
76;;;###autoload 75;;;###autoload
77 ;(defun gnus-audio-disable-sound () 76 ;(defun gnus-audio-disable-sound ()
78; "Disable Sound Effects for Gnus." 77; "Disable Sound Effects for Gnus."
79; (interactive) 78; (interactive)
80; (setq gnus-audio-effects-enabled nil) 79; (setq gnus-audio-effects-enabled nil)
81; (run-hooks gnus-audio-disable-hooks)) 80; (gnus-run-hooks gnus-audio-disable-hooks))
82 81
83;;;###autoload 82;;;###autoload
84(defun gnus-audio-play (file) 83(defun gnus-audio-play (file)
diff --git a/lisp/gnus/gnus-bcklg.el b/lisp/gnus/gnus-bcklg.el
index ead87fe19a3..323bb9ff041 100644
--- a/lisp/gnus/gnus-bcklg.el
+++ b/lisp/gnus/gnus-bcklg.el
@@ -1,7 +1,7 @@
1;;; gnus-bcklg.el --- backlog functions for Gnus 1;;; gnus-bcklg.el --- backlog functions for Gnus
2;; Copyright (C) 1996,97 Free Software Foundation, Inc. 2;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: news 5;; Keywords: news
6 6
7;; This file is part of GNU Emacs. 7;; This file is part of GNU Emacs.
@@ -27,6 +27,8 @@
27 27
28(eval-when-compile (require 'cl)) 28(eval-when-compile (require 'cl))
29 29
30(eval-when-compile (require 'cl))
31
30(require 'gnus) 32(require 'gnus)
31 33
32;;; 34;;;
@@ -41,10 +43,9 @@
41 "Return the backlog buffer." 43 "Return the backlog buffer."
42 (or (get-buffer gnus-backlog-buffer) 44 (or (get-buffer gnus-backlog-buffer)
43 (save-excursion 45 (save-excursion
44 (set-buffer (get-buffer-create gnus-backlog-buffer)) 46 (set-buffer (gnus-get-buffer-create gnus-backlog-buffer))
45 (buffer-disable-undo (current-buffer)) 47 (buffer-disable-undo (current-buffer))
46 (setq buffer-read-only t) 48 (setq buffer-read-only t)
47 (gnus-add-current-to-buffer-list)
48 (get-buffer gnus-backlog-buffer)))) 49 (get-buffer gnus-backlog-buffer))))
49 50
50(defun gnus-backlog-setup () 51(defun gnus-backlog-setup ()
@@ -122,7 +123,8 @@
122 (1+ beg) 'gnus-backlog (current-buffer) (point-max))) 123 (1+ beg) 'gnus-backlog (current-buffer) (point-max)))
123 (delete-region beg end) 124 (delete-region beg end)
124 ;; Return success. 125 ;; Return success.
125 t))))))) 126 t))
127 (setq gnus-backlog-articles (delq ident gnus-backlog-articles)))))))
126 128
127(defun gnus-backlog-request-article (group number buffer) 129(defun gnus-backlog-request-article (group number buffer)
128 (when (numberp number) 130 (when (numberp number)
diff --git a/lisp/gnus/gnus-cache.el b/lisp/gnus/gnus-cache.el
index 3a7cd8df8b5..ce97a82a6ea 100644
--- a/lisp/gnus/gnus-cache.el
+++ b/lisp/gnus/gnus-cache.el
@@ -1,7 +1,7 @@
1;;; gnus-cache.el --- cache interface for Gnus 1;;; gnus-cache.el --- cache interface for Gnus
2;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. 2;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: news 5;; Keywords: news
6 6
7;; This file is part of GNU Emacs. 7;; This file is part of GNU Emacs.
@@ -27,6 +27,8 @@
27 27
28(eval-when-compile (require 'cl)) 28(eval-when-compile (require 'cl))
29 29
30(eval-when-compile (require 'cl))
31
30(require 'gnus) 32(require 'gnus)
31(require 'gnus-int) 33(require 'gnus-int)
32(require 'gnus-range) 34(require 'gnus-range)
@@ -34,16 +36,6 @@
34(eval-when-compile 36(eval-when-compile
35 (require 'gnus-sum)) 37 (require 'gnus-sum))
36 38
37(defgroup gnus-cache nil
38 "Cache interface."
39 :group 'gnus)
40
41(defcustom gnus-cache-directory
42 (nnheader-concat gnus-directory "cache/")
43 "*The directory where cached articles will be stored."
44 :group 'gnus-cache
45 :type 'directory)
46
47(defcustom gnus-cache-active-file 39(defcustom gnus-cache-active-file
48 (concat (file-name-as-directory gnus-cache-directory) "active") 40 (concat (file-name-as-directory gnus-cache-directory) "active")
49 "*The cache active file." 41 "*The cache active file."
@@ -60,15 +52,33 @@
60 :group 'gnus-cache 52 :group 'gnus-cache
61 :type '(set (const ticked) (const dormant) (const unread) (const read))) 53 :type '(set (const ticked) (const dormant) (const unread) (const read)))
62 54
55(defcustom gnus-cacheable-groups nil
56 "*Groups that match this regexp will be cached.
57
58If you only want to cache your nntp groups, you could set this
59variable to \"^nntp\".
60
61If a group matches both gnus-cacheable-groups and gnus-uncacheable-groups
62it's not cached."
63 :group 'gnus-cache
64 :type '(choice (const :tag "off" nil)
65 regexp))
66
63(defcustom gnus-uncacheable-groups nil 67(defcustom gnus-uncacheable-groups nil
64 "*Groups that match this regexp will not be cached. 68 "*Groups that match this regexp will not be cached.
65 69
66If you want to avoid caching your nnml groups, you could set this 70If you want to avoid caching your nnml groups, you could set this
67variable to \"^nnml\"." 71variable to \"^nnml\".
72
73If a group matches both gnus-cacheable-groups and gnus-uncacheable-groups
74it's not cached."
68 :group 'gnus-cache 75 :group 'gnus-cache
69 :type '(choice (const :tag "off" nil) 76 :type '(choice (const :tag "off" nil)
70 regexp)) 77 regexp))
71 78
79(defvar gnus-cache-overview-coding-system 'raw-text
80 "Coding system used on Gnus cache files.")
81
72 82
73 83
74;;; Internal variables. 84;;; Internal variables.
@@ -116,7 +126,9 @@ variable to \"^nnml\"."
116 (set-buffer buffer) 126 (set-buffer buffer)
117 (if (> (buffer-size) 0) 127 (if (> (buffer-size) 0)
118 ;; Non-empty overview, write it to a file. 128 ;; Non-empty overview, write it to a file.
119 (gnus-write-buffer overview-file) 129 (let ((coding-system-for-write
130 gnus-cache-overview-coding-system))
131 (gnus-write-buffer overview-file))
120 ;; Empty overview file, remove it 132 ;; Empty overview file, remove it
121 (when (file-exists-p overview-file) 133 (when (file-exists-p overview-file)
122 (delete-file overview-file)) 134 (delete-file overview-file))
@@ -145,11 +157,13 @@ variable to \"^nnml\"."
145 headers (copy-sequence headers)) 157 headers (copy-sequence headers))
146 (mail-header-set-number headers (cdr result)))) 158 (mail-header-set-number headers (cdr result))))
147 (let ((number (mail-header-number headers)) 159 (let ((number (mail-header-number headers))
148 file dir) 160 file)
149 (when (and number 161 (when (and number
150 (> number 0) ; Reffed article. 162 (> number 0) ; Reffed article.
151 (or force 163 (or force
152 (and (or (not gnus-uncacheable-groups) 164 (and (or (not gnus-cacheable-groups)
165 (string-match gnus-cacheable-groups group))
166 (or (not gnus-uncacheable-groups)
153 (not (string-match 167 (not (string-match
154 gnus-uncacheable-groups group))) 168 gnus-uncacheable-groups group)))
155 (gnus-cache-member-of-class 169 (gnus-cache-member-of-class
@@ -157,7 +171,7 @@ variable to \"^nnml\"."
157 (not (file-exists-p (setq file (gnus-cache-file-name 171 (not (file-exists-p (setq file (gnus-cache-file-name
158 group number))))) 172 group number)))))
159 ;; Possibly create the cache directory. 173 ;; Possibly create the cache directory.
160 (gnus-make-directory (setq dir (file-name-directory file))) 174 (gnus-make-directory (file-name-directory file))
161 ;; Save the article in the cache. 175 ;; Save the article in the cache.
162 (if (file-exists-p file) 176 (if (file-exists-p file)
163 t ; The article already is saved. 177 t ; The article already is saved.
@@ -316,10 +330,10 @@ variable to \"^nnml\"."
316If not given a prefix, use the process marked articles instead. 330If not given a prefix, use the process marked articles instead.
317Returns the list of articles entered." 331Returns the list of articles entered."
318 (interactive "P") 332 (interactive "P")
319 (gnus-set-global-variables)
320 (let ((articles (gnus-summary-work-articles n)) 333 (let ((articles (gnus-summary-work-articles n))
321 article out) 334 article out)
322 (while (setq article (pop articles)) 335 (while (setq article (pop articles))
336 (gnus-summary-remove-process-mark article)
323 (if (natnump article) 337 (if (natnump article)
324 (when (gnus-cache-possibly-enter-article 338 (when (gnus-cache-possibly-enter-article
325 gnus-newsgroup-name article 339 gnus-newsgroup-name article
@@ -327,7 +341,6 @@ Returns the list of articles entered."
327 nil nil nil t) 341 nil nil nil t)
328 (push article out)) 342 (push article out))
329 (gnus-message 2 "Can't cache article %d" article)) 343 (gnus-message 2 "Can't cache article %d" article))
330 (gnus-summary-remove-process-mark article)
331 (gnus-summary-update-secondary-mark article)) 344 (gnus-summary-update-secondary-mark article))
332 (gnus-summary-next-subject 1) 345 (gnus-summary-next-subject 1)
333 (gnus-summary-position-point) 346 (gnus-summary-position-point)
@@ -338,15 +351,14 @@ Returns the list of articles entered."
338If not given a prefix, use the process marked articles instead. 351If not given a prefix, use the process marked articles instead.
339Returns the list of articles removed." 352Returns the list of articles removed."
340 (interactive "P") 353 (interactive "P")
341 (gnus-set-global-variables)
342 (gnus-cache-change-buffer gnus-newsgroup-name) 354 (gnus-cache-change-buffer gnus-newsgroup-name)
343 (let ((articles (gnus-summary-work-articles n)) 355 (let ((articles (gnus-summary-work-articles n))
344 article out) 356 article out)
345 (while articles 357 (while articles
346 (setq article (pop articles)) 358 (setq article (pop articles))
359 (gnus-summary-remove-process-mark article)
347 (when (gnus-cache-possibly-remove-article article nil nil nil t) 360 (when (gnus-cache-possibly-remove-article article nil nil nil t)
348 (push article out)) 361 (push article out))
349 (gnus-summary-remove-process-mark article)
350 (gnus-summary-update-secondary-mark article)) 362 (gnus-summary-update-secondary-mark article))
351 (gnus-summary-next-subject 1) 363 (gnus-summary-next-subject 1)
352 (gnus-summary-position-point) 364 (gnus-summary-position-point)
@@ -359,13 +371,16 @@ Returns the list of articles removed."
359(defun gnus-summary-insert-cached-articles () 371(defun gnus-summary-insert-cached-articles ()
360 "Insert all the articles cached for this group into the current buffer." 372 "Insert all the articles cached for this group into the current buffer."
361 (interactive) 373 (interactive)
362 (let ((cached gnus-newsgroup-cached) 374 (let ((cached (sort (copy-sequence gnus-newsgroup-cached) '<))
363 (gnus-verbose (max 6 gnus-verbose))) 375 (gnus-verbose (max 6 gnus-verbose)))
364 (unless cached 376 (unless cached
365 (error "No cached articles for this group")) 377 (gnus-message 3 "No cached articles for this group"))
366 (while cached 378 (while cached
367 (gnus-summary-goto-subject (pop cached) t)))) 379 (gnus-summary-goto-subject (pop cached) t))))
368 380
381(defalias 'gnus-summary-limit-include-cached
382 'gnus-summary-insert-cached-articles)
383
369;;; Internal functions. 384;;; Internal functions.
370 385
371(defun gnus-cache-change-buffer (group) 386(defun gnus-cache-change-buffer (group)
@@ -380,7 +395,8 @@ Returns the list of articles removed."
380 (save-excursion 395 (save-excursion
381 (setq gnus-cache-buffer 396 (setq gnus-cache-buffer
382 (cons group 397 (cons group
383 (set-buffer (get-buffer-create " *gnus-cache-overview*")))) 398 (set-buffer (gnus-get-buffer-create
399 " *gnus-cache-overview*"))))
384 (buffer-disable-undo (current-buffer)) 400 (buffer-disable-undo (current-buffer))
385 ;; Insert the contents of this group's cache overview. 401 ;; Insert the contents of this group's cache overview.
386 (erase-buffer) 402 (erase-buffer)
@@ -408,12 +424,14 @@ Returns the list of articles removed."
408 ;; Translate the first colon into a slash. 424 ;; Translate the first colon into a slash.
409 (when (string-match ":" group) 425 (when (string-match ":" group)
410 (aset group (match-beginning 0) ?/)) 426 (aset group (match-beginning 0) ?/))
411 (nnheader-replace-chars-in-string group ?. ?/))))) 427 (nnheader-replace-chars-in-string group ?. ?/)))
428 t))
412 (if (stringp article) article (int-to-string article)))) 429 (if (stringp article) article (int-to-string article))))
413 430
414(defun gnus-cache-update-article (group article) 431(defun gnus-cache-update-article (group article)
415 "If ARTICLE is in the cache, remove it and re-enter it." 432 "If ARTICLE is in the cache, remove it and re-enter it."
416 (when (gnus-cache-possibly-remove-article article nil nil nil t) 433 (gnus-cache-change-buffer group)
434 (when (gnus-cache-possibly-remove-article article nil nil nil t)
417 (let ((gnus-use-cache nil)) 435 (let ((gnus-use-cache nil))
418 (gnus-cache-possibly-enter-article 436 (gnus-cache-possibly-enter-article
419 gnus-newsgroup-name article (gnus-summary-article-header article) 437 gnus-newsgroup-name article (gnus-summary-article-header article)
@@ -466,7 +484,7 @@ Returns the list of articles removed."
466 articles))) 484 articles)))
467 485
468(defun gnus-cache-braid-nov (group cached &optional file) 486(defun gnus-cache-braid-nov (group cached &optional file)
469 (let ((cache-buf (get-buffer-create " *gnus-cache*")) 487 (let ((cache-buf (gnus-get-buffer-create " *gnus-cache*"))
470 beg end) 488 beg end)
471 (gnus-cache-save-buffers) 489 (gnus-cache-save-buffers)
472 (save-excursion 490 (save-excursion
@@ -498,7 +516,7 @@ Returns the list of articles removed."
498 (kill-buffer cache-buf))) 516 (kill-buffer cache-buf)))
499 517
500(defun gnus-cache-braid-heads (group cached) 518(defun gnus-cache-braid-heads (group cached)
501 (let ((cache-buf (get-buffer-create " *gnus-cache*"))) 519 (let ((cache-buf (gnus-get-buffer-create " *gnus-cache*")))
502 (save-excursion 520 (save-excursion
503 (set-buffer cache-buf) 521 (set-buffer cache-buf)
504 (buffer-disable-undo (current-buffer)) 522 (buffer-disable-undo (current-buffer))
@@ -560,6 +578,7 @@ $ emacs -batch -l ~/.emacs -l gnus -f gnus-jog-cache"
560 "Read the cache active file." 578 "Read the cache active file."
561 (gnus-make-directory gnus-cache-directory) 579 (gnus-make-directory gnus-cache-directory)
562 (if (or (not (file-exists-p gnus-cache-active-file)) 580 (if (or (not (file-exists-p gnus-cache-active-file))
581 (zerop (nth 7 (file-attributes gnus-cache-active-file)))
563 force) 582 force)
564 ;; There is no active file, so we generate one. 583 ;; There is no active file, so we generate one.
565 (gnus-cache-generate-active) 584 (gnus-cache-generate-active)
@@ -614,8 +633,9 @@ If LOW, update the lower bound instead."
614 (if top 633 (if top
615 "" 634 ""
616 (string-match 635 (string-match
617 (concat "^" (file-name-as-directory 636 (concat "^" (regexp-quote
618 (expand-file-name gnus-cache-directory))) 637 (file-name-as-directory
638 (expand-file-name gnus-cache-directory))))
619 (directory-file-name directory)) 639 (directory-file-name directory))
620 (nnheader-replace-chars-in-string 640 (nnheader-replace-chars-in-string
621 (substring (directory-file-name directory) (match-end 0)) 641 (substring (directory-file-name directory) (match-end 0))
@@ -624,6 +644,8 @@ If LOW, update the lower bound instead."
624 (when top 644 (when top
625 (gnus-message 5 "Generating the cache active file...") 645 (gnus-message 5 "Generating the cache active file...")
626 (setq gnus-cache-active-hashtb (gnus-make-hashtable 123))) 646 (setq gnus-cache-active-hashtb (gnus-make-hashtable 123)))
647 (when (string-match "^\\(nn[^_]+\\)_" group)
648 (setq group (replace-match "\\1:" t t group)))
627 ;; Separate articles from all other files and directories. 649 ;; Separate articles from all other files and directories.
628 (while files 650 (while files
629 (if (string-match "^[0-9]+$" (file-name-nondirectory (car files))) 651 (if (string-match "^[0-9]+$" (file-name-nondirectory (car files)))
@@ -636,7 +658,7 @@ If LOW, update the lower bound instead."
636 ;; Go through all the other files. 658 ;; Go through all the other files.
637 (while alphs 659 (while alphs
638 (when (and (file-directory-p (car alphs)) 660 (when (and (file-directory-p (car alphs))
639 (not (string-match "^\\.\\.?$" 661 (not (string-match "^\\."
640 (file-name-nondirectory (car alphs))))) 662 (file-name-nondirectory (car alphs)))))
641 ;; We descend directories. 663 ;; We descend directories.
642 (gnus-cache-generate-active (car alphs))) 664 (gnus-cache-generate-active (car alphs)))
diff --git a/lisp/gnus/gnus-cite.el b/lisp/gnus/gnus-cite.el
index 09d688c0416..b7093c99adc 100644
--- a/lisp/gnus/gnus-cite.el
+++ b/lisp/gnus/gnus-cite.el
@@ -1,12 +1,7 @@
1;;; gnus-cite.el --- parse citations in articles for Gnus 1;;; gnus-cite.el --- parse citations in articles for Gnus
2;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. 2;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Per Abrahamsen <abraham@iesd.auc.dk> 4;; Author: Per Abhiddenware; you can redistribute it and/or modify
5;; Keywords: news, mail
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software; you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by 5;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation; either version 2, or (at your option) 6;; the Free Software Foundation; either version 2, or (at your option)
12;; any later version. 7;; any later version.
@@ -27,6 +22,8 @@
27 22
28(eval-when-compile (require 'cl)) 23(eval-when-compile (require 'cl))
29 24
25(eval-when-compile (require 'cl))
26
30(require 'gnus) 27(require 'gnus)
31(require 'gnus-art) 28(require 'gnus-art)
32(require 'gnus-range) 29(require 'gnus-range)
@@ -41,7 +38,7 @@
41 38
42(defcustom gnus-cite-reply-regexp 39(defcustom gnus-cite-reply-regexp
43 "^\\(Subject: Re\\|In-Reply-To\\|References\\):" 40 "^\\(Subject: Re\\|In-Reply-To\\|References\\):"
44 "If headers match this regexp it is reasonable to believe that 41 "*If headers match this regexp it is reasonable to believe that
45article has citations." 42article has citations."
46 :group 'gnus-cite 43 :group 'gnus-cite
47 :type 'string) 44 :type 'string)
@@ -52,8 +49,13 @@ article has citations."
52 :type '(choice (const :tag "no" nil) 49 :type '(choice (const :tag "no" nil)
53 (const :tag "yes" t))) 50 (const :tag "yes" t)))
54 51
55(defcustom gnus-cited-text-button-line-format "%(%{[...]%}%)\n" 52(defcustom gnus-cited-opened-text-button-line-format "%(%{[-]%}%)\n"
56 "Format of cited text buttons." 53 "Format of opened cited text buttons."
54 :group 'gnus-cite
55 :type 'string)
56
57(defcustom gnus-cited-closed-text-button-line-format "%(%{[+]%}%)\n"
58 "Format of closed cited text buttons."
57 :group 'gnus-cite 59 :group 'gnus-cite
58 :type 'string) 60 :type 'string)
59 61
@@ -71,8 +73,8 @@ Set it to nil to parse all articles."
71 integer)) 73 integer))
72 74
73(defcustom gnus-cite-prefix-regexp 75(defcustom gnus-cite-prefix-regexp
74 "^[]>|:}+ ]*[]>|:}+]\\(.*>\\)?\\|^.*>" 76 "^[]>|:}+ ]*[]>|:}+]\\(.*>\\)?\\|^.*>"
75 "Regexp matching the longest possible citation prefix on a line." 77 "*Regexp matching the longest possible citation prefix on a line."
76 :group 'gnus-cite 78 :group 'gnus-cite
77 :type 'regexp) 79 :type 'regexp)
78 80
@@ -84,7 +86,7 @@ Set it to nil to parse all articles."
84(defcustom gnus-supercite-regexp 86(defcustom gnus-supercite-regexp
85 (concat "^\\(" gnus-cite-prefix-regexp "\\)? *" 87 (concat "^\\(" gnus-cite-prefix-regexp "\\)? *"
86 ">>>>> +\"\\([^\"\n]+\\)\" +==") 88 ">>>>> +\"\\([^\"\n]+\\)\" +==")
87 "Regexp matching normal Supercite attribution lines. 89 "*Regexp matching normal Supercite attribution lines.
88The first grouping must match prefixes added by other packages." 90The first grouping must match prefixes added by other packages."
89 :group 'gnus-cite 91 :group 'gnus-cite
90 :type 'regexp) 92 :type 'regexp)
@@ -100,21 +102,21 @@ The first regexp group should match the Supercite attribution."
100 :group 'gnus-cite 102 :group 'gnus-cite
101 :type 'integer) 103 :type 'integer)
102 104
103(defcustom gnus-cite-attribution-prefix 105(defcustom gnus-cite-attribution-prefix
104 "in article\\|in <\\|On \\(Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\|Sun\\)," 106 "In article\\|in <\\|On \\(Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\|Sun\\),"
105 "Regexp matching the beginning of an attribution line." 107 "*Regexp matching the beginning of an attribution line."
106 :group 'gnus-cite 108 :group 'gnus-cite
107 :type 'regexp) 109 :type 'regexp)
108 110
109(defcustom gnus-cite-attribution-suffix 111(defcustom gnus-cite-attribution-suffix
110 "\\(\\(wrote\\|writes\\|said\\|says\\|>\\)\\(:\\|\\.\\.\\.\\)\\)[ ]*$" 112 "\\(\\(wrote\\|writes\\|said\\|says\\|>\\)\\(:\\|\\.\\.\\.\\)\\)[ \t]*$"
111 "Regexp matching the end of an attribution line. 113 "*Regexp matching the end of an attribution line.
112The text matching the first grouping will be used as a button." 114The text matching the first grouping will be used as a button."
113 :group 'gnus-cite 115 :group 'gnus-cite
114 :type 'regexp) 116 :type 'regexp)
115 117
116(defface gnus-cite-attribution-face '((t 118(defface gnus-cite-attribution-face '((t
117 (:underline t))) 119 (:italic t)))
118 "Face used for attribution lines.") 120 "Face used for attribution lines.")
119 121
120(defcustom gnus-cite-attribution-face 'gnus-cite-attribution-face 122(defcustom gnus-cite-attribution-face 'gnus-cite-attribution-face
@@ -237,7 +239,7 @@ It is merged with the face for the cited text belonging to the attribution."
237 '(gnus-cite-face-1 gnus-cite-face-2 gnus-cite-face-3 gnus-cite-face-4 239 '(gnus-cite-face-1 gnus-cite-face-2 gnus-cite-face-3 gnus-cite-face-4
238 gnus-cite-face-5 gnus-cite-face-6 gnus-cite-face-7 gnus-cite-face-8 240 gnus-cite-face-5 gnus-cite-face-6 gnus-cite-face-7 gnus-cite-face-8
239 gnus-cite-face-9 gnus-cite-face-10 gnus-cite-face-11) 241 gnus-cite-face-9 gnus-cite-face-10 gnus-cite-face-11)
240 "List of faces used for highlighting citations. 242 "*List of faces used for highlighting citations.
241 243
242When there are citations from multiple articles in the same message, 244When there are citations from multiple articles in the same message,
243Gnus will try to give each citation from each article its own face. 245Gnus will try to give each citation from each article its own face.
@@ -258,6 +260,7 @@ This should make it easier to see who wrote what."
258;;; Internal Variables: 260;;; Internal Variables:
259 261
260(defvar gnus-cite-article nil) 262(defvar gnus-cite-article nil)
263(defvar gnus-cite-overlay-list nil)
261 264
262(defvar gnus-cite-prefix-alist nil) 265(defvar gnus-cite-prefix-alist nil)
263;; Alist of citation prefixes. 266;; Alist of citation prefixes.
@@ -280,11 +283,16 @@ This should make it easier to see who wrote what."
280;; PREFIX: Is the citation prefix of the attribution line(s), and 283;; PREFIX: Is the citation prefix of the attribution line(s), and
281;; TAG: Is a Supercite tag, if any. 284;; TAG: Is a Supercite tag, if any.
282 285
283(defvar gnus-cited-text-button-line-format-alist 286(defvar gnus-cited-opened-text-button-line-format-alist
284 `((?b (marker-position beg) ?d) 287 `((?b (marker-position beg) ?d)
285 (?e (marker-position end) ?d) 288 (?e (marker-position end) ?d)
289 (?n (count-lines beg end) ?d)
286 (?l (- end beg) ?d))) 290 (?l (- end beg) ?d)))
287(defvar gnus-cited-text-button-line-format-spec nil) 291(defvar gnus-cited-opened-text-button-line-format-spec nil)
292(defvar gnus-cited-closed-text-button-line-format-alist
293 gnus-cited-opened-text-button-line-format-alist)
294(defvar gnus-cited-closed-text-button-line-format-spec nil)
295
288 296
289;;; Commands: 297;;; Commands:
290 298
@@ -383,7 +391,7 @@ Lines matching `gnus-cite-attribution-suffix' and perhaps
383 (gnus-article-search-signature) 391 (gnus-article-search-signature)
384 (push (cons (point-marker) "") marks) 392 (push (cons (point-marker) "") marks)
385 ;; Sort the marks. 393 ;; Sort the marks.
386 (setq marks (sort marks (lambda (m1 m2) (< (car m1) (car m2))))) 394 (setq marks (sort marks 'car-less-than-car))
387 (let ((omarks marks)) 395 (let ((omarks marks))
388 (setq marks nil) 396 (setq marks nil)
389 (while (cdr omarks) 397 (while (cdr omarks)
@@ -449,9 +457,8 @@ See the documentation for `gnus-article-highlight-citation'.
449If given a negative prefix, always show; if given a positive prefix, 457If given a negative prefix, always show; if given a positive prefix,
450always hide." 458always hide."
451 (interactive (append (gnus-article-hidden-arg) (list 'force))) 459 (interactive (append (gnus-article-hidden-arg) (list 'force)))
452 (setq gnus-cited-text-button-line-format-spec 460 (gnus-set-format 'cited-opened-text-button t)
453 (gnus-parse-format gnus-cited-text-button-line-format 461 (gnus-set-format 'cited-closed-text-button t)
454 gnus-cited-text-button-line-format-alist t))
455 (save-excursion 462 (save-excursion
456 (set-buffer gnus-article-buffer) 463 (set-buffer gnus-article-buffer)
457 (cond 464 (cond
@@ -466,7 +473,7 @@ always hide."
466 (inhibit-point-motion-hooks t) 473 (inhibit-point-motion-hooks t)
467 (props (nconc (list 'article-type 'cite) 474 (props (nconc (list 'article-type 'cite)
468 gnus-hidden-properties)) 475 gnus-hidden-properties))
469 beg end) 476 beg end start)
470 (while marks 477 (while marks
471 (setq beg nil 478 (setq beg nil
472 end nil) 479 end nil)
@@ -486,30 +493,58 @@ always hide."
486 (setq beg nil) 493 (setq beg nil)
487 (setq beg (point-marker)))) 494 (setq beg (point-marker))))
488 (when (and beg end) 495 (when (and beg end)
496 ;; We use markers for the end-points to facilitate later
497 ;; wrapping and mangling of text.
498 (setq beg (set-marker (make-marker) beg)
499 end (set-marker (make-marker) end))
489 (gnus-add-text-properties beg end props) 500 (gnus-add-text-properties beg end props)
490 (goto-char beg) 501 (goto-char beg)
491 (unless (save-excursion (search-backward "\n\n" nil t)) 502 (unless (save-excursion (search-backward "\n\n" nil t))
492 (insert "\n")) 503 (insert "\n"))
493 (put-text-property 504 (put-text-property
494 (point) 505 (setq start (point-marker))
495 (progn 506 (progn
496 (gnus-article-add-button 507 (gnus-article-add-button
497 (point) 508 (point)
498 (progn (eval gnus-cited-text-button-line-format-spec) (point)) 509 (progn (eval gnus-cited-closed-text-button-line-format-spec)
499 `gnus-article-toggle-cited-text (cons beg end)) 510 (point))
511 `gnus-article-toggle-cited-text
512 (list (cons beg end) start))
500 (point)) 513 (point))
501 'article-type 'annotation) 514 'article-type 'annotation)
502 (set-marker beg (point))))))))) 515 (set-marker beg (point)))))))))
503 516
504(defun gnus-article-toggle-cited-text (region) 517(defun gnus-article-toggle-cited-text (args)
505 "Toggle hiding the text in REGION." 518 "Toggle hiding the text in REGION."
506 (let (buffer-read-only) 519 (let* ((region (car args))
520 (start (cadr args))
521 (hidden
522 (text-property-any
523 (car region) (1- (cdr region))
524 (car gnus-hidden-properties) (cadr gnus-hidden-properties)))
525 (inhibit-point-motion-hooks t)
526 buffer-read-only)
507 (funcall 527 (funcall
508 (if (text-property-any 528 (if hidden
509 (car region) (1- (cdr region))
510 (car gnus-hidden-properties) (cadr gnus-hidden-properties))
511 'remove-text-properties 'gnus-add-text-properties) 529 'remove-text-properties 'gnus-add-text-properties)
512 (car region) (cdr region) gnus-hidden-properties))) 530 (car region) (cdr region) gnus-hidden-properties)
531 (save-excursion
532 (goto-char start)
533 (gnus-delete-line)
534 (put-text-property
535 (point)
536 (progn
537 (gnus-article-add-button
538 (point)
539 (progn (eval
540 (if hidden
541 gnus-cited-opened-text-button-line-format-spec
542 gnus-cited-closed-text-button-line-format-spec))
543 (point))
544 `gnus-article-toggle-cited-text
545 args)
546 (point))
547 'article-type 'annotation))))
513 548
514(defun gnus-article-hide-citation-maybe (&optional arg force) 549(defun gnus-article-hide-citation-maybe (&optional arg force)
515 "Toggle hiding of cited text that has an attribution line. 550 "Toggle hiding of cited text that has an attribution line.
@@ -520,7 +555,7 @@ percent and at least `gnus-cite-hide-absolute' lines of the body is
520cited text with attributions. When called interactively, these two 555cited text with attributions. When called interactively, these two
521variables are ignored. 556variables are ignored.
522See also the documentation for `gnus-article-highlight-citation'." 557See also the documentation for `gnus-article-highlight-citation'."
523 (interactive (append (gnus-article-hidden-arg) (list 'force))) 558 (interactive (append (gnus-article-hidden-arg) '(force)))
524 (unless (gnus-article-check-hidden-text 'cite arg) 559 (unless (gnus-article-check-hidden-text 'cite arg)
525 (save-excursion 560 (save-excursion
526 (set-buffer gnus-article-buffer) 561 (set-buffer gnus-article-buffer)
@@ -531,27 +566,27 @@ See also the documentation for `gnus-article-highlight-citation'."
531 (atts gnus-cite-attribution-alist) 566 (atts gnus-cite-attribution-alist)
532 (buffer-read-only nil) 567 (buffer-read-only nil)
533 (inhibit-point-motion-hooks t) 568 (inhibit-point-motion-hooks t)
534 (hiden 0) 569 (hidden 0)
535 total) 570 total)
536 (goto-char (point-max)) 571 (goto-char (point-max))
537 (gnus-article-search-signature) 572 (gnus-article-search-signature)
538 (setq total (count-lines start (point))) 573 (setq total (count-lines start (point)))
539 (while atts 574 (while atts
540 (setq hiden (+ hiden (length (cdr (assoc (cdar atts) 575 (setq hidden (+ hidden (length (cdr (assoc (cdar atts)
541 gnus-cite-prefix-alist)))) 576 gnus-cite-prefix-alist))))
542 atts (cdr atts))) 577 atts (cdr atts)))
543 (when (or force 578 (when (or force
544 (and (> (* 100 hiden) (* gnus-cite-hide-percentage total)) 579 (and (> (* 100 hidden) (* gnus-cite-hide-percentage total))
545 (> hiden gnus-cite-hide-absolute))) 580 (> hidden gnus-cite-hide-absolute)))
546 (setq atts gnus-cite-attribution-alist) 581 (setq atts gnus-cite-attribution-alist)
547 (while atts 582 (while atts
548 (setq total (cdr (assoc (cdar atts) gnus-cite-prefix-alist)) 583 (setq total (cdr (assoc (cdar atts) gnus-cite-prefix-alist))
549 atts (cdr atts)) 584 atts (cdr atts))
550 (while total 585 (while total
551 (setq hiden (car total) 586 (setq hidden (car total)
552 total (cdr total)) 587 total (cdr total))
553 (goto-line hiden) 588 (goto-line hidden)
554 (unless (assq hiden gnus-cite-attribution-alist) 589 (unless (assq hidden gnus-cite-attribution-alist)
555 (gnus-add-text-properties 590 (gnus-add-text-properties
556 (point) (progn (forward-line 1) (point)) 591 (point) (progn (forward-line 1) (point))
557 (nconc (list 'article-type 'cite) 592 (nconc (list 'article-type 'cite)
@@ -572,13 +607,17 @@ See also the documentation for `gnus-article-highlight-citation'."
572 607
573(defun gnus-cite-parse-maybe (&optional force) 608(defun gnus-cite-parse-maybe (&optional force)
574 ;; Parse if the buffer has changes since last time. 609 ;; Parse if the buffer has changes since last time.
575 (if (equal gnus-cite-article gnus-article-current) 610 (if (and (not force)
611 (equal gnus-cite-article gnus-article-current))
576 () 612 ()
613 (gnus-cite-localize)
577 ;;Reset parser information. 614 ;;Reset parser information.
578 (setq gnus-cite-prefix-alist nil 615 (setq gnus-cite-prefix-alist nil
579 gnus-cite-attribution-alist nil 616 gnus-cite-attribution-alist nil
580 gnus-cite-loose-prefix-alist nil 617 gnus-cite-loose-prefix-alist nil
581 gnus-cite-loose-attribution-alist nil) 618 gnus-cite-loose-attribution-alist nil)
619 (while gnus-cite-overlay-list
620 (gnus-delete-overlay (pop gnus-cite-overlay-list)))
582 ;; Parse if not too large. 621 ;; Parse if not too large.
583 (if (and (not force) 622 (if (and (not force)
584 gnus-cite-parse-max-size 623 gnus-cite-parse-max-size
@@ -858,9 +897,9 @@ See also the documentation for `gnus-article-highlight-citation'."
858 ;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line. 897 ;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line.
859 (when face 898 (when face
860 (let ((inhibit-point-motion-hooks t) 899 (let ((inhibit-point-motion-hooks t)
861 from to) 900 from to overlay)
862 (goto-line number) 901 (goto-line number)
863 (unless (eobp);; Sometimes things become confused. 902 (unless (eobp) ; Sometimes things become confused.
864 (forward-char (length prefix)) 903 (forward-char (length prefix))
865 (skip-chars-forward " \t") 904 (skip-chars-forward " \t")
866 (setq from (point)) 905 (setq from (point))
@@ -868,11 +907,14 @@ See also the documentation for `gnus-article-highlight-citation'."
868 (skip-chars-backward " \t") 907 (skip-chars-backward " \t")
869 (setq to (point)) 908 (setq to (point))
870 (when (< from to) 909 (when (< from to)
871 (gnus-overlay-put (gnus-make-overlay from to) 'face face)))))) 910 (push (setq overlay (gnus-make-overlay from to))
911 gnus-cite-overlay-list)
912 (gnus-overlay-put overlay 'face face))))))
872 913
873(defun gnus-cite-toggle (prefix) 914(defun gnus-cite-toggle (prefix)
874 (save-excursion 915 (save-excursion
875 (set-buffer gnus-article-buffer) 916 (set-buffer gnus-article-buffer)
917 (gnus-cite-parse-maybe)
876 (let ((buffer-read-only nil) 918 (let ((buffer-read-only nil)
877 (numbers (cdr (assoc prefix gnus-cite-prefix-alist))) 919 (numbers (cdr (assoc prefix gnus-cite-prefix-alist)))
878 (inhibit-point-motion-hooks t) 920 (inhibit-point-motion-hooks t)
@@ -903,10 +945,14 @@ See also the documentation for `gnus-article-highlight-citation'."
903 (setq prefix (car entry)))) 945 (setq prefix (car entry))))
904 prefix)) 946 prefix))
905 947
906(gnus-add-shutdown 'gnus-cache-close 'gnus) 948(defun gnus-cite-localize ()
907 949 "Make the citation variables local to the article buffer."
908(defun gnus-cache-close () 950 (let ((vars '(gnus-cite-article
909 (setq gnus-cite-prefix-alist nil)) 951 gnus-cite-overlay-list gnus-cite-prefix-alist
952 gnus-cite-attribution-alist gnus-cite-loose-prefix-alist
953 gnus-cite-loose-attribution-alist)))
954 (while vars
955 (make-local-variable (pop vars)))))
910 956
911(gnus-ems-redefine) 957(gnus-ems-redefine)
912 958
diff --git a/lisp/gnus/gnus-cus.el b/lisp/gnus/gnus-cus.el
index 37c0bf955c3..025273b6add 100644
--- a/lisp/gnus/gnus-cus.el
+++ b/lisp/gnus/gnus-cus.el
@@ -51,7 +51,7 @@ if that value is non-nil."
51 (setq major-mode 'gnus-custom-mode 51 (setq major-mode 'gnus-custom-mode
52 mode-name "Gnus Customize") 52 mode-name "Gnus Customize")
53 (use-local-map widget-keymap) 53 (use-local-map widget-keymap)
54 (run-hooks 'gnus-custom-mode-hook)) 54 (gnus-run-hooks 'gnus-custom-mode-hook))
55 55
56;;; Group Customization: 56;;; Group Customization:
57 57
@@ -155,7 +155,11 @@ Which articles to display on entering the group.
155 unread and ticked articles.") 155 unread and ticked articles.")
156 156
157 (comment (string :tag "Comment") "\ 157 (comment (string :tag "Comment") "\
158An arbitrary comment on the group.")) 158An arbitrary comment on the group.")
159
160 (visible (const :tag "Permanently visible" t) "\
161Always display this group, even when there are no unread articles
162in it.."))
159 "Alist of valid group parameters. 163 "Alist of valid group parameters.
160 164
161Each entry has the form (NAME TYPE DOC), where NAME is the parameter 165Each entry has the form (NAME TYPE DOC), where NAME is the parameter
@@ -166,11 +170,10 @@ DOC is a documentation string for the parameter.")
166(defvar gnus-custom-method) 170(defvar gnus-custom-method)
167(defvar gnus-custom-group) 171(defvar gnus-custom-group)
168 172
169(defun gnus-group-customize (group &optional part) 173(defun gnus-group-customize (group)
170 "Edit the group on the current line." 174 "Edit the group on the current line."
171 (interactive (list (gnus-group-group-name))) 175 (interactive (list (gnus-group-group-name)))
172 (let ((part (or part 'info)) 176 (let (info
173 info
174 (types (mapcar (lambda (entry) 177 (types (mapcar (lambda (entry)
175 `(cons :format "%v%h\n" 178 `(cons :format "%v%h\n"
176 :doc ,(nth 2 entry) 179 :doc ,(nth 2 entry)
@@ -182,8 +185,8 @@ DOC is a documentation string for the parameter.")
182 (unless (setq info (gnus-get-info group)) 185 (unless (setq info (gnus-get-info group))
183 (error "Killed group; can't be edited")) 186 (error "Killed group; can't be edited"))
184 ;; Ready. 187 ;; Ready.
185 (kill-buffer (get-buffer-create "*Gnus Customize*")) 188 (kill-buffer (gnus-get-buffer-create "*Gnus Customize*"))
186 (switch-to-buffer (get-buffer-create "*Gnus Customize*")) 189 (switch-to-buffer (gnus-get-buffer-create "*Gnus Customize*"))
187 (gnus-custom-mode) 190 (gnus-custom-mode)
188 (make-local-variable 'gnus-custom-group) 191 (make-local-variable 'gnus-custom-group)
189 (setq gnus-custom-group group) 192 (setq gnus-custom-group group)
@@ -283,12 +286,12 @@ number will be marked as read and removed from the summary buffer.
283`gnus-thread-score-function' says how to compute the total score 286`gnus-thread-score-function' says how to compute the total score
284for a thread.") 287for a thread.")
285 288
286 (files (repeat :tag "Files" file) "\ 289 (files (repeat :inline t :tag "Files" file) "\
287The value of this entry should be any number of file names. 290The value of this entry should be any number of file names.
288These files are assumed to be score files as well, and will be loaded 291These files are assumed to be score files as well, and will be loaded
289the same way this one was.") 292the same way this one was.")
290 293
291 (exclude-files (repeat :tag "Exclude-files" file) "\ 294 (exclude-files (repeat :inline t :tag "Exclude-files" file) "\
292The clue of this entry should be any number of files. 295The clue of this entry should be any number of files.
293These files will not be loaded, even though they would normally be so, 296These files will not be loaded, even though they would normally be so,
294for some reason or other.") 297for some reason or other.")
@@ -540,8 +543,8 @@ eh?")))
540 ,(nth 1 entry))) 543 ,(nth 1 entry)))
541 gnus-score-parameters))) 544 gnus-score-parameters)))
542 ;; Ready. 545 ;; Ready.
543 (kill-buffer (get-buffer-create "*Gnus Customize*")) 546 (kill-buffer (gnus-get-buffer-create "*Gnus Customize*"))
544 (switch-to-buffer (get-buffer-create "*Gnus Customize*")) 547 (switch-to-buffer (gnus-get-buffer-create "*Gnus Customize*"))
545 (gnus-custom-mode) 548 (gnus-custom-mode)
546 (make-local-variable 'gnus-custom-score-alist) 549 (make-local-variable 'gnus-custom-score-alist)
547 (setq gnus-custom-score-alist scores) 550 (setq gnus-custom-score-alist scores)
@@ -647,4 +650,3 @@ articles in the thread.
647(provide 'gnus-cus) 650(provide 'gnus-cus)
648 651
649;;; gnus-cus.el ends here 652;;; gnus-cus.el ends here
650
diff --git a/lisp/gnus/gnus-demon.el b/lisp/gnus/gnus-demon.el
index 0900784af84..58f26e85d51 100644
--- a/lisp/gnus/gnus-demon.el
+++ b/lisp/gnus/gnus-demon.el
@@ -1,7 +1,7 @@
1;;; gnus-demon.el --- daemonic Gnus behaviour 1;;; gnus-demon.el --- daemonic Gnus behaviour
2;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. 2;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: news 5;; Keywords: news
6 6
7;; This file is part of GNU Emacs. 7;; This file is part of GNU Emacs.
@@ -27,9 +27,14 @@
27 27
28(eval-when-compile (require 'cl)) 28(eval-when-compile (require 'cl))
29 29
30(eval-when-compile (require 'cl))
31
30(require 'gnus) 32(require 'gnus)
31(require 'gnus-int) 33(require 'gnus-int)
32(require 'nnheader) 34(require 'nnheader)
35(require 'nntp)
36(require 'nnmail)
37(require 'gnus-util)
33(eval-and-compile 38(eval-and-compile
34 (if (string-match "XEmacs" (emacs-version)) 39 (if (string-match "XEmacs" (emacs-version))
35 (require 'itimer) 40 (require 'itimer)
@@ -95,9 +100,7 @@ time Emacs has been idle for IDLE `gnus-demon-timestep's."
95 100
96(defun gnus-demon-remove-handler (function &optional no-init) 101(defun gnus-demon-remove-handler (function &optional no-init)
97 "Remove the handler FUNCTION from the list of handlers." 102 "Remove the handler FUNCTION from the list of handlers."
98 (setq gnus-demon-handlers 103 (gnus-pull function gnus-demon-handlers)
99 (delq (assq function gnus-demon-handlers)
100 gnus-demon-handlers))
101 (unless no-init 104 (unless no-init
102 (gnus-demon-init))) 105 (gnus-demon-init)))
103 106
@@ -105,9 +108,8 @@ time Emacs has been idle for IDLE `gnus-demon-timestep's."
105 "Initialize the Gnus daemon." 108 "Initialize the Gnus daemon."
106 (interactive) 109 (interactive)
107 (gnus-demon-cancel) 110 (gnus-demon-cancel)
108 (if (null gnus-demon-handlers) 111 (when gnus-demon-handlers
109 () ; Nothing to do. 112 ;; Set up the timer.
110 ;; Set up timer.
111 (setq gnus-demon-timer 113 (setq gnus-demon-timer
112 (nnheader-run-at-time 114 (nnheader-run-at-time
113 gnus-demon-timestep gnus-demon-timestep 'gnus-demon)) 115 gnus-demon-timestep gnus-demon-timestep 'gnus-demon))
@@ -130,7 +132,8 @@ time Emacs has been idle for IDLE `gnus-demon-timestep's."
130 (when gnus-demon-timer 132 (when gnus-demon-timer
131 (nnheader-cancel-timer gnus-demon-timer)) 133 (nnheader-cancel-timer gnus-demon-timer))
132 (setq gnus-demon-timer nil 134 (setq gnus-demon-timer nil
133 gnus-use-demon nil) 135 gnus-use-demon nil
136 gnus-demon-idle-has-been-called nil)
134 (condition-case () 137 (condition-case ()
135 (nnheader-cancel-function-timers 'gnus-demon) 138 (nnheader-cancel-function-timers 'gnus-demon)
136 (error t))) 139 (error t)))
@@ -259,6 +262,18 @@ time Emacs has been idle for IDLE `gnus-demon-timestep's."
259 (save-window-excursion 262 (save-window-excursion
260 (gnus-close-backends))) 263 (gnus-close-backends)))
261 264
265(defun gnus-demon-add-nntp-close-connection ()
266 "Add daemonic nntp server disconnection to Gnus.
267If no commands have gone out via nntp during the last five
268minutes, the connection is closed."
269 (gnus-demon-add-handler 'gnus-demon-close-connections 5 nil))
270
271(defun gnus-demon-nntp-close-connection ()
272 (save-window-excursion
273 (when (nnmail-time-less '(0 300)
274 (nnmail-time-since nntp-last-command-time))
275 (nntp-close-server))))
276
262(defun gnus-demon-add-scanmail () 277(defun gnus-demon-add-scanmail ()
263 "Add daemonic scanning of mail from the mail backends." 278 "Add daemonic scanning of mail from the mail backends."
264 (gnus-demon-add-handler 'gnus-demon-scan-mail 120 60)) 279 (gnus-demon-add-handler 'gnus-demon-scan-mail 120 60))
@@ -267,6 +282,7 @@ time Emacs has been idle for IDLE `gnus-demon-timestep's."
267 (save-window-excursion 282 (save-window-excursion
268 (let ((servers gnus-opened-servers) 283 (let ((servers gnus-opened-servers)
269 server) 284 server)
285 (gnus-clear-inboxes-moved)
270 (while (setq server (car (pop servers))) 286 (while (setq server (car (pop servers)))
271 (and (gnus-check-backend-function 'request-scan (car server)) 287 (and (gnus-check-backend-function 'request-scan (car server))
272 (or (gnus-server-opened server) 288 (or (gnus-server-opened server)
@@ -278,11 +294,15 @@ time Emacs has been idle for IDLE `gnus-demon-timestep's."
278 (gnus-demon-add-handler 'gnus-demon-scan-news 120 60)) 294 (gnus-demon-add-handler 'gnus-demon-scan-news 120 60))
279 295
280(defun gnus-demon-scan-news () 296(defun gnus-demon-scan-news ()
281 (save-window-excursion 297 (let ((win (current-window-configuration)))
282 (when (gnus-alive-p) 298 (unwind-protect
283 (save-excursion 299 (save-window-excursion
284 (set-buffer gnus-group-buffer) 300 (save-excursion
285 (gnus-group-get-new-news))))) 301 (when (gnus-alive-p)
302 (save-excursion
303 (set-buffer gnus-group-buffer)
304 (gnus-group-get-new-news)))))
305 (set-window-configuration win))))
286 306
287(defun gnus-demon-add-scan-timestamps () 307(defun gnus-demon-add-scan-timestamps ()
288 "Add daemonic updating of timestamps in empty newgroups." 308 "Add daemonic updating of timestamps in empty newgroups."
diff --git a/lisp/gnus/gnus-dup.el b/lisp/gnus/gnus-dup.el
index dd0bce1f051..ac0ac315fb1 100644
--- a/lisp/gnus/gnus-dup.el
+++ b/lisp/gnus/gnus-dup.el
@@ -1,7 +1,7 @@
1;;; gnus-dup.el --- suppression of duplicate articles in Gnus 1;;; gnus-dup.el --- suppression of duplicate articles in Gnus
2;; Copyright (C) 1996,97 Free Software Foundation, Inc. 2;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: news 5;; Keywords: news
6 6
7;; This file is part of GNU Emacs. 7;; This file is part of GNU Emacs.
@@ -32,6 +32,8 @@
32 32
33(eval-when-compile (require 'cl)) 33(eval-when-compile (require 'cl))
34 34
35(eval-when-compile (require 'cl))
36
35(require 'gnus) 37(require 'gnus)
36(require 'gnus-art) 38(require 'gnus-art)
37 39
@@ -118,7 +120,7 @@ seen in the same session."
118 (while (setq datum (pop data)) 120 (while (setq datum (pop data))
119 (when (and (not (gnus-data-pseudo-p datum)) 121 (when (and (not (gnus-data-pseudo-p datum))
120 (> (gnus-data-number datum) 0) 122 (> (gnus-data-number datum) 0)
121 (gnus-data-read-p datum) 123 (not (memq (gnus-data-number datum) gnus-newsgroup-unreads))
122 (not (= (gnus-data-mark datum) gnus-canceled-mark)) 124 (not (= (gnus-data-mark datum) gnus-canceled-mark))
123 (setq msgid (mail-header-id (gnus-data-header datum))) 125 (setq msgid (mail-header-id (gnus-data-header datum)))
124 (not (nnheader-fake-message-id-p msgid)) 126 (not (nnheader-fake-message-id-p msgid))
diff --git a/lisp/gnus/gnus-eform.el b/lisp/gnus/gnus-eform.el
index b8df3d3c89e..6a93242feaf 100644
--- a/lisp/gnus/gnus-eform.el
+++ b/lisp/gnus/gnus-eform.el
@@ -1,7 +1,7 @@
1;;; gnus-eform.el --- a mode for editing forms for Gnus 1;;; gnus-eform.el --- a mode for editing forms for Gnus
2;; Copyright (C) 1996,97 Free Software Foundation, Inc. 2;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: news 5;; Keywords: news
6 6
7;; This file is part of GNU Emacs. 7;; This file is part of GNU Emacs.
@@ -48,8 +48,8 @@
48 48
49;;; Internal variables 49;;; Internal variables
50 50
51(defvar gnus-edit-form-done-function nil)
52(defvar gnus-edit-form-buffer "*Gnus edit form*") 51(defvar gnus-edit-form-buffer "*Gnus edit form*")
52(defvar gnus-edit-form-done-function nil)
53 53
54(defvar gnus-edit-form-mode-map nil) 54(defvar gnus-edit-form-mode-map nil)
55(unless gnus-edit-form-mode-map 55(unless gnus-edit-form-mode-map
@@ -65,7 +65,7 @@
65 '("Edit Form" 65 '("Edit Form"
66 ["Exit and save changes" gnus-edit-form-done t] 66 ["Exit and save changes" gnus-edit-form-done t]
67 ["Exit" gnus-edit-form-exit t])) 67 ["Exit" gnus-edit-form-exit t]))
68 (run-hooks 'gnus-edit-form-menu-hook))) 68 (gnus-run-hooks 'gnus-edit-form-menu-hook)))
69 69
70(defun gnus-edit-form-mode () 70(defun gnus-edit-form-mode ()
71 "Major mode for editing forms. 71 "Major mode for editing forms.
@@ -81,16 +81,15 @@ It is a slightly enhanced emacs-lisp-mode.
81 (use-local-map gnus-edit-form-mode-map) 81 (use-local-map gnus-edit-form-mode-map)
82 (make-local-variable 'gnus-edit-form-done-function) 82 (make-local-variable 'gnus-edit-form-done-function)
83 (make-local-variable 'gnus-prev-winconf) 83 (make-local-variable 'gnus-prev-winconf)
84 (run-hooks 'gnus-edit-form-mode-hook)) 84 (gnus-run-hooks 'gnus-edit-form-mode-hook))
85 85
86(defun gnus-edit-form (form documentation exit-func) 86(defun gnus-edit-form (form documentation exit-func)
87 "Edit FORM in a new buffer. 87 "Edit FORM in a new buffer.
88Call EXIT-FUNC on exit. Display DOCUMENTATION in the beginning 88Call EXIT-FUNC on exit. Display DOCUMENTATION in the beginning
89of the buffer." 89of the buffer."
90 (let ((winconf (current-window-configuration))) 90 (let ((winconf (current-window-configuration)))
91 (set-buffer (get-buffer-create gnus-edit-form-buffer)) 91 (set-buffer (gnus-get-buffer-create gnus-edit-form-buffer))
92 (gnus-configure-windows 'edit-form) 92 (gnus-configure-windows 'edit-form)
93 (gnus-add-current-to-buffer-list)
94 (gnus-edit-form-mode) 93 (gnus-edit-form-mode)
95 (setq gnus-prev-winconf winconf) 94 (setq gnus-prev-winconf winconf)
96 (setq gnus-edit-form-done-function exit-func) 95 (setq gnus-edit-form-done-function exit-func)
diff --git a/lisp/gnus/gnus-ems.el b/lisp/gnus/gnus-ems.el
index f2eae20dd1a..39bb98d1d5f 100644
--- a/lisp/gnus/gnus-ems.el
+++ b/lisp/gnus/gnus-ems.el
@@ -1,7 +1,7 @@
1;;; gnus-ems.el --- functions for making Gnus work under different Emacsen 1;;; gnus-ems.el --- functions for making Gnus work under different Emacsen
2;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. 2;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: news 5;; Keywords: news
6 6
7;; This file is part of GNU Emacs. 7;; This file is part of GNU Emacs.
@@ -56,16 +56,19 @@
56 (let ((inhibit-point-motion-hooks t) 56 (let ((inhibit-point-motion-hooks t)
57 from to) 57 from to)
58 (goto-line number) 58 (goto-line number)
59 (if (boundp 'MULE) 59 (unless (eobp) ; Sometimes things become confused (broken).
60 (forward-char (chars-in-string prefix)) 60 (if (boundp 'MULE)
61 (forward-char (length prefix))) 61 (forward-char (chars-in-string prefix))
62 (skip-chars-forward " \t") 62 (forward-char (length prefix)))
63 (setq from (point)) 63 (skip-chars-forward " \t")
64 (end-of-line 1) 64 (setq from (point))
65 (skip-chars-backward " \t") 65 (end-of-line 1)
66 (setq to (point)) 66 (skip-chars-backward " \t")
67 (when (< from to) 67 (setq to (point))
68 (gnus-overlay-put (gnus-make-overlay from to) 'face face))))) 68 (when (< from to)
69 (push (setq overlay (gnus-make-overlay from to))
70 gnus-cite-overlay-list)
71 (gnus-overlay-put (gnus-make-overlay from to) 'face face))))))
69 72
70(defun gnus-mule-max-width-function (el max-width) 73(defun gnus-mule-max-width-function (el max-width)
71 (` (let* ((val (eval (, el))) 74 (` (let* ((val (eval (, el)))
@@ -78,6 +81,12 @@
78(defun gnus-encode-coding-string (string system) 81(defun gnus-encode-coding-string (string system)
79 string) 82 string)
80 83
84(defun gnus-decode-coding-string (string system)
85 string)
86
87(defun gnus-encode-coding-string (string system)
88 string)
89
81(eval-and-compile 90(eval-and-compile
82 (if (string-match "XEmacs\\|Lucid" emacs-version) 91 (if (string-match "XEmacs\\|Lucid" emacs-version)
83 nil 92 nil
@@ -90,7 +99,8 @@
90 (gnus-xmas-define)) 99 (gnus-xmas-define))
91 100
92 ((or (not (boundp 'emacs-minor-version)) 101 ((or (not (boundp 'emacs-minor-version))
93 (< emacs-minor-version 30)) 102 (and (< emacs-major-version 20)
103 (< emacs-minor-version 30)))
94 ;; Remove the `intangible' prop. 104 ;; Remove the `intangible' prop.
95 (let ((props (and (boundp 'gnus-hidden-properties) 105 (let ((props (and (boundp 'gnus-hidden-properties)
96 gnus-hidden-properties))) 106 gnus-hidden-properties)))
@@ -126,7 +136,8 @@
126(eval-and-compile 136(eval-and-compile
127 (let ((case-fold-search t)) 137 (let ((case-fold-search t))
128 (cond 138 (cond
129 ((string-match "windows-nt\\|os/2\\|emx" (format "%s" system-type)) 139 ((string-match "windows-nt\\|os/2\\|emx\\|cygwin"
140 (symbol-name system-type))
130 (setq nnheader-file-name-translation-alist 141 (setq nnheader-file-name-translation-alist
131 (append nnheader-file-name-translation-alist 142 (append nnheader-file-name-translation-alist
132 '((?: . ?_) 143 '((?: . ?_)
@@ -172,8 +183,9 @@
172 "Display table used in summary mode buffers.") 183 "Display table used in summary mode buffers.")
173 (fset 'gnus-cite-add-face 'gnus-mule-cite-add-face) 184 (fset 'gnus-cite-add-face 'gnus-mule-cite-add-face)
174 (fset 'gnus-max-width-function 'gnus-mule-max-width-function) 185 (fset 'gnus-max-width-function 'gnus-mule-max-width-function)
175 (fset 'gnus-summary-set-display-table 'ignore) 186 (fset 'gnus-summary-set-display-table (lambda ()))
176 (fset 'gnus-encode-coding-string 'encode-coding-string) 187 (fset 'gnus-encode-coding-string 'encode-coding-string)
188 (fset 'gnus-decode-coding-string 'decode-coding-string)
177 189
178 (when (boundp 'gnus-check-before-posting) 190 (when (boundp 'gnus-check-before-posting)
179 (setq gnus-check-before-posting 191 (setq gnus-check-before-posting
@@ -214,12 +226,58 @@
214(defun gnus-add-minor-mode (mode name map) 226(defun gnus-add-minor-mode (mode name map)
215 (if (fboundp 'add-minor-mode) 227 (if (fboundp 'add-minor-mode)
216 (add-minor-mode mode name map) 228 (add-minor-mode mode name map)
229 (set (make-local-variable mode) t)
217 (unless (assq mode minor-mode-alist) 230 (unless (assq mode minor-mode-alist)
218 (push `(,mode ,name) minor-mode-alist)) 231 (push `(,mode ,name) minor-mode-alist))
219 (unless (assq mode minor-mode-map-alist) 232 (unless (assq mode minor-mode-map-alist)
220 (push (cons mode map) 233 (push (cons mode map)
221 minor-mode-map-alist)))) 234 minor-mode-map-alist))))
222 235
236(defun gnus-x-splash ()
237 "Show a splash screen using a pixmap in the current buffer."
238 (let ((dir (nnheader-find-etc-directory "gnus"))
239 pixmap file height beg i)
240 (save-excursion
241 (switch-to-buffer (gnus-get-buffer-create gnus-group-buffer))
242 (let ((buffer-read-only nil))
243 (erase-buffer)
244 (when (and dir
245 (file-exists-p (setq file (concat dir "x-splash"))))
246 (nnheader-temp-write nil
247 (insert-file-contents file)
248 (goto-char (point-min))
249 (ignore-errors
250 (setq pixmap (read (current-buffer))))))
251 (when pixmap
252 (erase-buffer)
253 (unless (facep 'gnus-splash)
254 (make-face 'gnus-splash))
255 (setq height (/ (car pixmap) (frame-char-height))
256 width (/ (cadr pixmap) (frame-char-width)))
257 (set-face-foreground 'gnus-splash "ForestGreen")
258 (set-face-stipple 'gnus-splash pixmap)
259 (insert-char ?\n (* (/ (window-height) 2 height) height))
260 (setq i height)
261 (while (> i 0)
262 (insert-char ? (* (+ (/ (window-width) 2 width) 1) width))
263 (setq beg (point))
264 (insert-char ? width)
265 (set-text-properties beg (point) '(face gnus-splash))
266 (insert "\n")
267 (decf i))
268 (goto-char (point-min))
269 (sit-for 0))))))
270
271(if (fboundp 'split-string)
272 (fset 'gnus-split-string 'split-string)
273 (defun gnus-split-string (string pattern)
274 "Return a list of substrings of STRING which are separated by PATTERN."
275 (let (parts (start 0))
276 (while (string-match pattern string start)
277 (setq parts (cons (substring string start (match-beginning 0)) parts)
278 start (match-end 0)))
279 (nreverse (cons (substring string start) parts)))))
280
223(provide 'gnus-ems) 281(provide 'gnus-ems)
224 282
225;; Local Variables: 283;; Local Variables:
diff --git a/lisp/gnus/gnus-gl.el b/lisp/gnus/gnus-gl.el
index 786cda40b86..93ef91564a4 100644
--- a/lisp/gnus/gnus-gl.el
+++ b/lisp/gnus/gnus-gl.el
@@ -1,5 +1,5 @@
1;;; gnus-gl.el --- an interface to GroupLens for Gnus 1;;; gnus-gl.el --- an interface to GroupLens for Gnus
2;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. 2;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Brad Miller <bmiller@cs.umn.edu> 4;; Author: Brad Miller <bmiller@cs.umn.edu>
5;; Keywords: news, score 5;; Keywords: news, score
@@ -234,7 +234,7 @@ If this times out we give up and assume that something has died..." )
234(defun bbb-connect-to-bbbd (host port) 234(defun bbb-connect-to-bbbd (host port)
235 (unless grouplens-bbb-buffer 235 (unless grouplens-bbb-buffer
236 (setq grouplens-bbb-buffer 236 (setq grouplens-bbb-buffer
237 (get-buffer-create (format " *BBBD trace: %s*" host))) 237 (gnus-get-buffer-create (format " *BBBD trace: %s*" host)))
238 (save-excursion 238 (save-excursion
239 (set-buffer grouplens-bbb-buffer) 239 (set-buffer grouplens-bbb-buffer)
240 (make-local-variable 'bbb-read-point) 240 (make-local-variable 'bbb-read-point)
@@ -299,7 +299,7 @@ If this times out we give up and assume that something has died..." )
299;;;; Login Functions 299;;;; Login Functions
300;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 300;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
301(defun bbb-login () 301(defun bbb-login ()
302 "return the token number if login is successful, otherwise return nil" 302 "return the token number if login is successful, otherwise return nil."
303 (interactive) 303 (interactive)
304 (setq grouplens-bbb-token nil) 304 (setq grouplens-bbb-token nil)
305 (if (not (equal grouplens-pseudonym "")) 305 (if (not (equal grouplens-pseudonym ""))
@@ -324,7 +324,7 @@ If this times out we give up and assume that something has died..." )
324(gnus-add-shutdown 'bbb-logout 'gnus) 324(gnus-add-shutdown 'bbb-logout 'gnus)
325 325
326(defun bbb-logout () 326(defun bbb-logout ()
327 "logout of bbb session" 327 "logout of bbb session."
328 (when grouplens-bbb-token 328 (when grouplens-bbb-token
329 (let ((bbb-process 329 (let ((bbb-process
330 (bbb-connect-to-bbbd grouplens-bbb-host grouplens-bbb-port))) 330 (bbb-connect-to-bbbd grouplens-bbb-host grouplens-bbb-port)))
@@ -339,9 +339,8 @@ If this times out we give up and assume that something has died..." )
339;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 339;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
340 340
341(defun bbb-build-mid-scores-alist (groupname) 341(defun bbb-build-mid-scores-alist (groupname)
342 "this function can be called as part of the function to return the 342 "this function can be called as part of the function to return the list of score files to use.
343list of score files to use. See the gnus variable 343See the gnus variable gnus-score-find-score-files-function.
344gnus-score-find-score-files-function.
345 344
346*Note:* If you want to use grouplens scores along with calculated scores, 345*Note:* If you want to use grouplens scores along with calculated scores,
347you should see the offset and scale variables. At this point, I don't 346you should see the offset and scale variables. At this point, I don't
@@ -669,9 +668,8 @@ recommend using both scores and grouplens predictions together."
669 (gnus-summary-best-unread-article)) 668 (gnus-summary-best-unread-article))
670 669
671(defun grouplens-summary-catchup-and-exit (rating) 670(defun grouplens-summary-catchup-and-exit (rating)
672 "Mark all articles not marked as unread in this newsgroup as read, 671 "Mark all articles not marked as unread in this newsgroup as read, then exit.
673 then exit. If prefix argument ALL is non-nil, all articles are 672If prefix argument ALL is non-nil, all articles are marked as read."
674 marked as read."
675 (interactive "P") 673 (interactive "P")
676 (when rating 674 (when rating
677 (bbb-summary-rate-article rating)) 675 (bbb-summary-rate-article rating))
@@ -688,7 +686,6 @@ recommend using both scores and grouplens predictions together."
688 article) 686 article)
689 (while (setq article (pop articles)) 687 (while (setq article (pop articles))
690 (gnus-summary-goto-subject article) 688 (gnus-summary-goto-subject article)
691 (gnus-set-global-variables)
692 (bbb-summary-rate-article score 689 (bbb-summary-rate-article score
693 (mail-header-id 690 (mail-header-id
694 (gnus-summary-article-header article))))) 691 (gnus-summary-article-header article)))))
@@ -749,7 +746,7 @@ recommend using both scores and grouplens predictions together."
749(defconst gnus-gl-version "gnus-gl.el 2.50") 746(defconst gnus-gl-version "gnus-gl.el 2.50")
750(defconst gnus-gl-maintainer-address "grouplens-bug@cs.umn.edu") 747(defconst gnus-gl-maintainer-address "grouplens-bug@cs.umn.edu")
751(defun gnus-gl-submit-bug-report () 748(defun gnus-gl-submit-bug-report ()
752 "Submit via mail a bug report on gnus-gl" 749 "Submit via mail a bug report on gnus-gl."
753 (interactive) 750 (interactive)
754 (require 'reporter) 751 (require 'reporter)
755 (reporter-submit-bug-report gnus-gl-maintainer-address 752 (reporter-submit-bug-report gnus-gl-maintainer-address
@@ -766,7 +763,7 @@ recommend using both scores and grouplens predictions together."
766 'gnus-gl-get-trace)) 763 'gnus-gl-get-trace))
767 764
768(defun gnus-gl-get-trace () 765(defun gnus-gl-get-trace ()
769 "Insert the contents of the BBBD trace buffer" 766 "Insert the contents of the BBBD trace buffer."
770 (when grouplens-bbb-buffer 767 (when grouplens-bbb-buffer
771 (insert-buffer grouplens-bbb-buffer))) 768 (insert-buffer grouplens-bbb-buffer)))
772 769
@@ -853,7 +850,7 @@ recommend using both scores and grouplens predictions together."
853 (gnus-grouplens-make-menu-bar)) 850 (gnus-grouplens-make-menu-bar))
854 (gnus-add-minor-mode 851 (gnus-add-minor-mode
855 'gnus-grouplens-mode " GroupLens" gnus-grouplens-mode-map) 852 'gnus-grouplens-mode " GroupLens" gnus-grouplens-mode-map)
856 (run-hooks 'gnus-grouplens-mode-hook)))) 853 (gnus-run-hooks 'gnus-grouplens-mode-hook))))
857 854
858(provide 'gnus-gl) 855(provide 'gnus-gl)
859 856
diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el
index 5caa86ec704..4eea2c01923 100644
--- a/lisp/gnus/gnus-group.el
+++ b/lisp/gnus/gnus-group.el
@@ -1,7 +1,7 @@
1;;; gnus-group.el --- group mode commands for Gnus 1;;; gnus-group.el --- group mode commands for Gnus
2;; Copyright (C) 1996,97 Free Software Foundation, Inc. 2;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: news 5;; Keywords: news
6 6
7;; This file is part of GNU Emacs. 7;; This file is part of GNU Emacs.
@@ -27,6 +27,8 @@
27 27
28(eval-when-compile (require 'cl)) 28(eval-when-compile (require 'cl))
29 29
30(eval-when-compile (require 'cl))
31
30(require 'gnus) 32(require 'gnus)
31(require 'gnus-start) 33(require 'gnus-start)
32(require 'nnmail) 34(require 'nnmail)
@@ -37,13 +39,13 @@
37(require 'gnus-undo) 39(require 'gnus-undo)
38 40
39(defcustom gnus-group-archive-directory 41(defcustom gnus-group-archive-directory
40 "/ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list/" 42 "*ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list/"
41 "*The address of the (ding) archives." 43 "*The address of the (ding) archives."
42 :group 'gnus-group-foreign 44 :group 'gnus-group-foreign
43 :type 'directory) 45 :type 'directory)
44 46
45(defcustom gnus-group-recent-archive-directory 47(defcustom gnus-group-recent-archive-directory
46 "/ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list-recent/" 48 "*ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list-recent/"
47 "*The address of the most recent (ding) articles." 49 "*The address of the most recent (ding) articles."
48 :group 'gnus-group-foreign 50 :group 'gnus-group-foreign
49 :type 'directory) 51 :type 'directory)
@@ -89,7 +91,7 @@ unread articles in the groups.
89 91
90If nil, no groups are permanently visible." 92If nil, no groups are permanently visible."
91 :group 'gnus-group-listing 93 :group 'gnus-group-listing
92 :type '(choice regexp (const nil))) 94 :type 'regexp)
93 95
94(defcustom gnus-list-groups-with-ticked-articles t 96(defcustom gnus-list-groups-with-ticked-articles t
95 "*If non-nil, list groups that have only ticked articles. 97 "*If non-nil, list groups that have only ticked articles.
@@ -261,10 +263,13 @@ variable."
261 :type 'hook) 263 :type 'hook)
262 264
263(defcustom gnus-useful-groups 265(defcustom gnus-useful-groups
264 `(("(ding) mailing list mirrored at sunsite.auc.dk" 266 '(("(ding) mailing list mirrored at sunsite.auc.dk"
265 "emacs.ding" 267 "emacs.ding"
266 (nntp "sunsite.auc.dk" 268 (nntp "sunsite.auc.dk"
267 (nntp-address "sunsite.auc.dk"))) 269 (nntp-address "sunsite.auc.dk")))
270 ("gnus-bug archive"
271 "gnus-bug"
272 (nndir "/ftp@ftp.ifi.uio.no:/pub/emacs/gnus/gnus-bug/"))
268 ("Gnus help group" 273 ("Gnus help group"
269 "gnus-help" 274 "gnus-help"
270 (nndoc "gnus-help" 275 (nndoc "gnus-help"
@@ -275,7 +280,7 @@ variable."
275 (unless file 280 (unless file
276 (error "Couldn't find doc group")) 281 (error "Couldn't find doc group"))
277 file)))))) 282 file))))))
278 "Alist of useful group-server pairs." 283 "*Alist of useful group-server pairs."
279 :group 'gnus-group-listing 284 :group 'gnus-group-listing
280 :type '(repeat (list (string :tag "Description") 285 :type '(repeat (list (string :tag "Description")
281 (string :tag "Name") 286 (string :tag "Name")
@@ -316,7 +321,7 @@ variable."
316 gnus-group-mail-low-empty-face) 321 gnus-group-mail-low-empty-face)
317 (t . 322 (t .
318 gnus-group-mail-low-face)) 323 gnus-group-mail-low-face))
319 "Controls the highlighting of group buffer lines. 324 "*Controls the highlighting of group buffer lines.
320 325
321Below is a list of `Form'/`Face' pairs. When deciding how a a 326Below is a list of `Form'/`Face' pairs. When deciding how a a
322particular group line should be displayed, each form is 327particular group line should be displayed, each form is
@@ -428,6 +433,7 @@ ticked: The number of ticked articles."
428 "p" gnus-group-prev-unread-group 433 "p" gnus-group-prev-unread-group
429 "\177" gnus-group-prev-unread-group 434 "\177" gnus-group-prev-unread-group
430 [delete] gnus-group-prev-unread-group 435 [delete] gnus-group-prev-unread-group
436 [backspace] gnus-group-prev-unread-group
431 "N" gnus-group-next-group 437 "N" gnus-group-next-group
432 "P" gnus-group-prev-group 438 "P" gnus-group-prev-group
433 "\M-n" gnus-group-next-unread-group-same-level 439 "\M-n" gnus-group-next-unread-group-same-level
@@ -707,7 +713,7 @@ ticked: The number of ticked articles."
707 (fboundp 'gnus-soup-pack-packet)] 713 (fboundp 'gnus-soup-pack-packet)]
708 ["Pack packet" gnus-soup-pack-packet (fboundp 'gnus-soup-pack-packet)] 714 ["Pack packet" gnus-soup-pack-packet (fboundp 'gnus-soup-pack-packet)]
709 ["Save areas" gnus-soup-save-areas (fboundp 'gnus-soup-pack-packet)] 715 ["Save areas" gnus-soup-save-areas (fboundp 'gnus-soup-pack-packet)]
710 ["Brew SOUP" gnus-soup-brew-soup (fboundp 'gnus-soup-pack-packet)]) 716 ["Brew SOUP" gnus-group-brew-soup (fboundp 'gnus-soup-pack-packet)])
711 ["Send a bug report" gnus-bug t] 717 ["Send a bug report" gnus-bug t]
712 ["Send a mail" gnus-group-mail t] 718 ["Send a mail" gnus-group-mail t]
713 ["Post an article..." gnus-group-post-news t] 719 ["Post an article..." gnus-group-post-news t]
@@ -726,10 +732,11 @@ ticked: The number of ticked articles."
726 ["Read manual" gnus-info-find-node t] 732 ["Read manual" gnus-info-find-node t]
727 ["Flush score cache" gnus-score-flush-cache t] 733 ["Flush score cache" gnus-score-flush-cache t]
728 ["Toggle topics" gnus-topic-mode t] 734 ["Toggle topics" gnus-topic-mode t]
735 ["Send a bug report" gnus-bug t]
729 ["Exit from Gnus" gnus-group-exit t] 736 ["Exit from Gnus" gnus-group-exit t]
730 ["Exit without saving" gnus-group-quit t])) 737 ["Exit without saving" gnus-group-quit t]))
731 738
732 (run-hooks 'gnus-group-menu-hook))) 739 (gnus-run-hooks 'gnus-group-menu-hook)))
733 740
734(defun gnus-group-mode () 741(defun gnus-group-mode ()
735 "Major mode for reading news. 742 "Major mode for reading news.
@@ -768,13 +775,16 @@ The following commands are available:
768 (add-hook 'post-command-hook 'gnus-clear-inboxes-moved nil t) 775 (add-hook 'post-command-hook 'gnus-clear-inboxes-moved nil t)
769 (when gnus-use-undo 776 (when gnus-use-undo
770 (gnus-undo-mode 1)) 777 (gnus-undo-mode 1))
771 (run-hooks 'gnus-group-mode-hook)) 778 (when gnus-slave
779 (gnus-slave-mode))
780 (gnus-run-hooks 'gnus-group-mode-hook))
772 781
773(defun gnus-update-group-mark-positions () 782(defun gnus-update-group-mark-positions ()
774 (save-excursion 783 (save-excursion
775 (let ((gnus-process-mark 128) 784 (let ((gnus-process-mark ?\200)
776 (gnus-group-marked '("dummy.group")) 785 (gnus-group-marked '("dummy.group"))
777 (gnus-active-hashtb (make-vector 10 0))) 786 (gnus-active-hashtb (make-vector 10 0))
787 (topic ""))
778 (gnus-set-active "dummy.group" '(0 . 0)) 788 (gnus-set-active "dummy.group" '(0 . 0))
779 (gnus-set-work-buffer) 789 (gnus-set-work-buffer)
780 (gnus-group-insert-group-line "dummy.group" 0 nil 0 nil) 790 (gnus-group-insert-group-line "dummy.group" 0 nil 0 nil)
@@ -810,9 +820,8 @@ The following commands are available:
810 (or level gnus-group-default-list-level gnus-level-subscribed)))) 820 (or level gnus-group-default-list-level gnus-level-subscribed))))
811 821
812(defun gnus-group-setup-buffer () 822(defun gnus-group-setup-buffer ()
813 (switch-to-buffer gnus-group-buffer) 823 (set-buffer (gnus-get-buffer-create gnus-group-buffer))
814 (unless (eq major-mode 'gnus-group-mode) 824 (unless (eq major-mode 'gnus-group-mode)
815 (gnus-add-current-to-buffer-list)
816 (gnus-group-mode) 825 (gnus-group-mode)
817 (when gnus-carpal 826 (when gnus-carpal
818 (gnus-carpal-setup-buffer 'group)))) 827 (gnus-carpal-setup-buffer 'group))))
@@ -946,7 +955,7 @@ If REGEXP, only list groups matching REGEXP."
946 955
947 (gnus-group-set-mode-line) 956 (gnus-group-set-mode-line)
948 (setq gnus-group-list-mode (cons level all)) 957 (setq gnus-group-list-mode (cons level all))
949 (run-hooks 'gnus-group-prepare-hook) 958 (gnus-run-hooks 'gnus-group-prepare-hook)
950 t)) 959 t))
951 960
952(defun gnus-group-prepare-flat-list-dead (groups level mark regexp) 961(defun gnus-group-prepare-flat-list-dead (groups level mark regexp)
@@ -1052,7 +1061,7 @@ If REGEXP, only list groups matching REGEXP."
1052 (gnus-tmp-moderated-string 1061 (gnus-tmp-moderated-string
1053 (if (eq gnus-tmp-moderated ?m) "(m)" "")) 1062 (if (eq gnus-tmp-moderated ?m) "(m)" ""))
1054 (gnus-tmp-method 1063 (gnus-tmp-method
1055 (gnus-server-get-method gnus-tmp-group gnus-tmp-method)) 1064 (gnus-server-get-method gnus-tmp-group gnus-tmp-method)) ;
1056 (gnus-tmp-news-server (or (cadr gnus-tmp-method) "")) 1065 (gnus-tmp-news-server (or (cadr gnus-tmp-method) ""))
1057 (gnus-tmp-news-method (or (car gnus-tmp-method) "")) 1066 (gnus-tmp-news-method (or (car gnus-tmp-method) ""))
1058 (gnus-tmp-news-method-string 1067 (gnus-tmp-news-method-string
@@ -1088,7 +1097,7 @@ If REGEXP, only list groups matching REGEXP."
1088 gnus-level ,gnus-tmp-level)) 1097 gnus-level ,gnus-tmp-level))
1089 (when (inline (gnus-visual-p 'group-highlight 'highlight)) 1098 (when (inline (gnus-visual-p 'group-highlight 'highlight))
1090 (forward-line -1) 1099 (forward-line -1)
1091 (run-hooks 'gnus-group-update-hook) 1100 (gnus-run-hooks 'gnus-group-update-hook)
1092 (forward-line)) 1101 (forward-line))
1093 ;; Allow XEmacs to remove front-sticky text properties. 1102 ;; Allow XEmacs to remove front-sticky text properties.
1094 (gnus-group-remove-excess-properties))) 1103 (gnus-group-remove-excess-properties)))
@@ -1111,7 +1120,7 @@ If REGEXP, only list groups matching REGEXP."
1111 (mailp (memq 'mail (assoc (symbol-name 1120 (mailp (memq 'mail (assoc (symbol-name
1112 (car (or method gnus-select-method))) 1121 (car (or method gnus-select-method)))
1113 gnus-valid-select-methods))) 1122 gnus-valid-select-methods)))
1114 (level (or (gnus-info-level info) 9)) 1123 (level (or (gnus-info-level info) gnus-level-killed))
1115 (score (or (gnus-info-score info) 0)) 1124 (score (or (gnus-info-score info) 0))
1116 (ticked (gnus-range-length (cdr (assq 'tick marked)))) 1125 (ticked (gnus-range-length (cdr (assq 'tick marked))))
1117 (group-age (gnus-group-timestamp-delta group)) 1126 (group-age (gnus-group-timestamp-delta group))
@@ -1122,7 +1131,7 @@ If REGEXP, only list groups matching REGEXP."
1122 (setq list (cdr list))) 1131 (setq list (cdr list)))
1123 (let ((face (cdar list))) 1132 (let ((face (cdar list)))
1124 (unless (eq face (get-text-property beg 'face)) 1133 (unless (eq face (get-text-property beg 'face))
1125 (gnus-put-text-property 1134 (gnus-put-text-property-excluding-characters-with-faces
1126 beg end 'face 1135 beg end 'face
1127 (setq face (if (boundp face) (symbol-value face) face))) 1136 (setq face (if (boundp face) (symbol-value face) face)))
1128 (gnus-extent-start-open beg))) 1137 (gnus-extent-start-open beg)))
@@ -1145,7 +1154,8 @@ already."
1145 found buffer-read-only) 1154 found buffer-read-only)
1146 ;; Enter the current status into the dribble buffer. 1155 ;; Enter the current status into the dribble buffer.
1147 (let ((entry (gnus-gethash group gnus-newsrc-hashtb))) 1156 (let ((entry (gnus-gethash group gnus-newsrc-hashtb)))
1148 (when (and entry (not (gnus-ephemeral-group-p group))) 1157 (when (and entry
1158 (not (gnus-ephemeral-group-p group)))
1149 (gnus-dribble-enter 1159 (gnus-dribble-enter
1150 (concat "(gnus-group-set-info '" 1160 (concat "(gnus-group-set-info '"
1151 (gnus-prin1-to-string (nth 2 entry)) 1161 (gnus-prin1-to-string (nth 2 entry))
@@ -1161,7 +1171,7 @@ already."
1161 (gnus-group-insert-group-line-info group) 1171 (gnus-group-insert-group-line-info group)
1162 (save-excursion 1172 (save-excursion
1163 (forward-line -1) 1173 (forward-line -1)
1164 (run-hooks 'gnus-group-update-group-hook))) 1174 (gnus-run-hooks 'gnus-group-update-group-hook)))
1165 (setq loc (1+ loc))) 1175 (setq loc (1+ loc)))
1166 (unless (or found visible-only) 1176 (unless (or found visible-only)
1167 ;; No such line in the buffer, find out where it's supposed to 1177 ;; No such line in the buffer, find out where it's supposed to
@@ -1183,7 +1193,7 @@ already."
1183 (gnus-group-insert-group-line-info group) 1193 (gnus-group-insert-group-line-info group)
1184 (save-excursion 1194 (save-excursion
1185 (forward-line -1) 1195 (forward-line -1)
1186 (run-hooks 'gnus-group-update-group-hook)))) 1196 (gnus-run-hooks 'gnus-group-update-group-hook))))
1187 (when gnus-group-update-group-function 1197 (when gnus-group-update-group-function
1188 (funcall gnus-group-update-group-function group)) 1198 (funcall gnus-group-update-group-function group))
1189 (gnus-group-set-mode-line))) 1199 (gnus-group-set-mode-line)))
@@ -1198,10 +1208,7 @@ already."
1198 (save-excursion 1208 (save-excursion
1199 (set-buffer gnus-group-buffer) 1209 (set-buffer gnus-group-buffer)
1200 (let* ((gformat (or gnus-group-mode-line-format-spec 1210 (let* ((gformat (or gnus-group-mode-line-format-spec
1201 (setq gnus-group-mode-line-format-spec 1211 (gnus-set-format 'group-mode)))
1202 (gnus-parse-format
1203 gnus-group-mode-line-format
1204 gnus-group-mode-line-format-alist))))
1205 (gnus-tmp-news-server (cadr gnus-select-method)) 1212 (gnus-tmp-news-server (cadr gnus-select-method))
1206 (gnus-tmp-news-method (car gnus-select-method)) 1213 (gnus-tmp-news-method (car gnus-select-method))
1207 (gnus-tmp-colon (if (equal gnus-tmp-news-server "") "" ":")) 1214 (gnus-tmp-colon (if (equal gnus-tmp-news-server "") "" ":"))
@@ -1232,7 +1239,8 @@ already."
1232(defun gnus-group-group-name () 1239(defun gnus-group-group-name ()
1233 "Get the name of the newsgroup on the current line." 1240 "Get the name of the newsgroup on the current line."
1234 (let ((group (get-text-property (gnus-point-at-bol) 'gnus-group))) 1241 (let ((group (get-text-property (gnus-point-at-bol) 'gnus-group)))
1235 (and group (symbol-name group)))) 1242 (when group
1243 (symbol-name group))))
1236 1244
1237(defun gnus-group-group-level () 1245(defun gnus-group-group-level ()
1238 "Get the level of the newsgroup on the current line." 1246 "Get the level of the newsgroup on the current line."
@@ -1257,8 +1265,8 @@ already."
1257(defun gnus-group-level (group) 1265(defun gnus-group-level (group)
1258 "Return the estimated level of GROUP." 1266 "Return the estimated level of GROUP."
1259 (or (gnus-info-level (gnus-get-info group)) 1267 (or (gnus-info-level (gnus-get-info group))
1260 (and (member group gnus-zombie-list) 8) 1268 (and (member group gnus-zombie-list) gnus-level-zombie)
1261 9)) 1269 gnus-level-killed))
1262 1270
1263(defun gnus-group-search-forward (&optional backward all level first-too) 1271(defun gnus-group-search-forward (&optional backward all level first-too)
1264 "Find the next newsgroup with unread articles. 1272 "Find the next newsgroup with unread articles.
@@ -1420,9 +1428,9 @@ Take into consideration N (the prefix) and the list of marked groups."
1420 (n (abs n)) 1428 (n (abs n))
1421 group groups) 1429 group groups)
1422 (save-excursion 1430 (save-excursion
1423 (while (and (> n 0) 1431 (while (> n 0)
1424 (setq group (gnus-group-group-name))) 1432 (if (setq group (gnus-group-group-name))
1425 (push group groups) 1433 (push group groups))
1426 (setq n (1- n)) 1434 (setq n (1- n))
1427 (gnus-group-next-group way))) 1435 (gnus-group-next-group way)))
1428 (nreverse groups))) 1436 (nreverse groups)))
@@ -1447,25 +1455,33 @@ Take into consideration N (the prefix) and the list of marked groups."
1447 (let ((group (gnus-group-group-name))) 1455 (let ((group (gnus-group-group-name)))
1448 (and group (list group)))))) 1456 (and group (list group))))))
1449 1457
1450(defun gnus-group-iterate (arg function) 1458;;; !!!Surely gnus-group-iterate should be a macro instead? I can't
1451 "Iterate FUNCTION over all process/prefixed groups. 1459;;; imagine why I went through these contortions...
1460(eval-and-compile
1461 (let ((function (make-symbol "gnus-group-iterate-function"))
1462 (window (make-symbol "gnus-group-iterate-window"))
1463 (groups (make-symbol "gnus-group-iterate-groups"))
1464 (group (make-symbol "gnus-group-iterate-group")))
1465 (eval
1466 `(defun gnus-group-iterate (arg ,function)
1467 "Iterate FUNCTION over all process/prefixed groups.
1452FUNCTION will be called with the group name as the paremeter 1468FUNCTION will be called with the group name as the paremeter
1453and with point over the group in question." 1469and with point over the group in question."
1454 (let ((groups (gnus-group-process-prefix arg)) 1470 (let ((,groups (gnus-group-process-prefix arg))
1455 (window (selected-window)) 1471 (,window (selected-window))
1456 group) 1472 ,group)
1457 (while (setq group (pop groups)) 1473 (while (setq ,group (pop ,groups))
1458 (select-window window) 1474 (select-window ,window)
1459 (gnus-group-remove-mark group) 1475 (gnus-group-remove-mark ,group)
1460 (save-selected-window 1476 (save-selected-window
1461 (save-excursion 1477 (save-excursion
1462 (funcall function group)))))) 1478 (funcall ,function ,group)))))))))
1463 1479
1464(put 'gnus-group-iterate 'lisp-indent-function 1) 1480(put 'gnus-group-iterate 'lisp-indent-function 1)
1465 1481
1466;; Selecting groups. 1482;; Selecting groups.
1467 1483
1468(defun gnus-group-read-group (&optional all no-article group) 1484(defun gnus-group-read-group (&optional all no-article group select-articles)
1469 "Read news in this newsgroup. 1485 "Read news in this newsgroup.
1470If the prefix argument ALL is non-nil, already read articles become 1486If the prefix argument ALL is non-nil, already read articles become
1471readable. IF ALL is a number, fetch this number of articles. If the 1487readable. IF ALL is a number, fetch this number of articles. If the
@@ -1496,7 +1512,7 @@ group."
1496 (cdr (assq 'tick marked))) 1512 (cdr (assq 'tick marked)))
1497 (gnus-range-length 1513 (gnus-range-length
1498 (cdr (assq 'dormant marked))))))) 1514 (cdr (assq 'dormant marked)))))))
1499 no-article nil no-display))) 1515 no-article nil no-display nil select-articles)))
1500 1516
1501(defun gnus-group-select-group (&optional all) 1517(defun gnus-group-select-group (&optional all)
1502 "Select this newsgroup. 1518 "Select this newsgroup.
@@ -1510,7 +1526,10 @@ If ALL is a number, fetch this number of articles."
1510 "Select the current group \"quickly\". 1526 "Select the current group \"quickly\".
1511This means that no highlighting or scoring will be performed. 1527This means that no highlighting or scoring will be performed.
1512If ALL (the prefix argument) is 0, don't even generate the summary 1528If ALL (the prefix argument) is 0, don't even generate the summary
1513buffer." 1529buffer.
1530
1531This might be useful if you want to toggle threading
1532before entering the group."
1514 (interactive "P") 1533 (interactive "P")
1515 (require 'gnus-score) 1534 (require 'gnus-score)
1516 (let (gnus-visual 1535 (let (gnus-visual
@@ -1539,10 +1558,6 @@ be permanent."
1539 gnus-summary-mode-hook gnus-select-group-hook 1558 gnus-summary-mode-hook gnus-select-group-hook
1540 (group (gnus-group-group-name)) 1559 (group (gnus-group-group-name))
1541 (method (gnus-find-method-for-group group))) 1560 (method (gnus-find-method-for-group group)))
1542 (setq method
1543 `(,(car method) ,(concat (cadr method) "-ephemeral")
1544 (,(intern (format "%s-address" (car method))) ,(cadr method))
1545 ,@(cddr method)))
1546 (gnus-group-read-ephemeral-group 1561 (gnus-group-read-ephemeral-group
1547 (gnus-group-prefixed-name group method) method))) 1562 (gnus-group-prefixed-name group method) method)))
1548 1563
@@ -1552,31 +1567,44 @@ be permanent."
1552Returns whether the fetching was successful or not." 1567Returns whether the fetching was successful or not."
1553 (interactive "sGroup name: ") 1568 (interactive "sGroup name: ")
1554 (unless (get-buffer gnus-group-buffer) 1569 (unless (get-buffer gnus-group-buffer)
1555 (gnus)) 1570 (gnus-no-server))
1556 (gnus-group-read-group nil nil group)) 1571 (gnus-group-read-group nil nil group))
1557 1572
1573;;;###autoload
1574(defun gnus-fetch-group-other-frame (group)
1575 "Pop up a frame and enter GROUP."
1576 (interactive "P")
1577 (let ((window (get-buffer-window gnus-group-buffer)))
1578 (cond (window
1579 (select-frame (window-frame window)))
1580 ((= (length (frame-list)) 1)
1581 (select-frame (make-frame)))
1582 (t
1583 (other-frame 1))))
1584 (gnus-fetch-group group))
1585
1558(defvar gnus-ephemeral-group-server 0) 1586(defvar gnus-ephemeral-group-server 0)
1559 1587
1560;; Enter a group that is not in the group buffer. Non-nil is returned 1588;; Enter a group that is not in the group buffer. Non-nil is returned
1561;; if selection was successful. 1589;; if selection was successful.
1562(defun gnus-group-read-ephemeral-group (group method &optional activate 1590(defun gnus-group-read-ephemeral-group (group method &optional activate
1563 quit-config request-only) 1591 quit-config request-only
1592 select-articles)
1564 "Read GROUP from METHOD as an ephemeral group. 1593 "Read GROUP from METHOD as an ephemeral group.
1565If ACTIVATE, request the group first. 1594If ACTIVATE, request the group first.
1566If QUIT-CONFIG, use that window configuration when exiting from the 1595If QUIT-CONFIG, use that window configuration when exiting from the
1567ephemeral group. 1596ephemeral group.
1568If REQUEST-ONLY, don't actually read the group; just request it. 1597If REQUEST-ONLY, don't actually read the group; just request it.
1598If SELECT-ARTICLES, only select those articles.
1569 1599
1570Return the name of the group is selection was successful." 1600Return the name of the group is selection was successful."
1571 ;; Transform the select method into a unique server. 1601 ;; Transform the select method into a unique server.
1572 (let ((saddr (intern (format "%s-address" (car method))))) 1602 (when (stringp method)
1573 (setq method (gnus-copy-sequence method)) 1603 (setq method (gnus-server-to-method method)))
1574 (require (car method)) 1604 (setq method
1575 (when (boundp saddr) 1605 `(,(car method) ,(concat (cadr method) "-ephemeral")
1576 (unless (assq saddr method) 1606 (,(intern (format "%s-address" (car method))) ,(cadr method))
1577 (nconc method `((,saddr ,(cadr method)))) 1607 ,@(cddr method)))
1578 (setf (cadr method) (format "%s-%d" (cadr method)
1579 (incf gnus-ephemeral-group-server))))))
1580 (let ((group (if (gnus-group-foreign-p group) group 1608 (let ((group (if (gnus-group-foreign-p group) group
1581 (gnus-group-prefixed-name group method)))) 1609 (gnus-group-prefixed-name group method))))
1582 (gnus-sethash 1610 (gnus-sethash
@@ -1588,6 +1616,7 @@ Return the name of the group is selection was successful."
1588 (cons gnus-summary-buffer 1616 (cons gnus-summary-buffer
1589 gnus-current-window-configuration)))))) 1617 gnus-current-window-configuration))))))
1590 gnus-newsrc-hashtb) 1618 gnus-newsrc-hashtb)
1619 (push method gnus-ephemeral-servers)
1591 (set-buffer gnus-group-buffer) 1620 (set-buffer gnus-group-buffer)
1592 (unless (gnus-check-server method) 1621 (unless (gnus-check-server method)
1593 (error "Unable to contact server: %s" (gnus-status-message method))) 1622 (error "Unable to contact server: %s" (gnus-status-message method)))
@@ -1599,7 +1628,7 @@ Return the name of the group is selection was successful."
1599 (if request-only 1628 (if request-only
1600 group 1629 group
1601 (condition-case () 1630 (condition-case ()
1602 (when (gnus-group-read-group t t group) 1631 (when (gnus-group-read-group t t group select-articles)
1603 group) 1632 group)
1604 ;;(error nil) 1633 ;;(error nil)
1605 (quit nil))))) 1634 (quit nil)))))
@@ -1774,6 +1803,8 @@ ADDRESS."
1774 (gnus-read-group "Group name: ") 1803 (gnus-read-group "Group name: ")
1775 (gnus-read-method "From method: "))) 1804 (gnus-read-method "From method: ")))
1776 1805
1806 (when (stringp method)
1807 (setq method (gnus-server-to-method method)))
1777 (let* ((meth (when (and method 1808 (let* ((meth (when (and method
1778 (not (gnus-server-equal method gnus-select-method))) 1809 (not (gnus-server-equal method gnus-select-method)))
1779 (if address (list (intern method) address) 1810 (if address (list (intern method) address)
@@ -1886,6 +1917,9 @@ and NEW-NAME will be prompted for."
1886 (gnus-set-active new-name (gnus-active group)) 1917 (gnus-set-active new-name (gnus-active group))
1887 (gnus-message 6 "Renaming group %s to %s...done" group new-name) 1918 (gnus-message 6 "Renaming group %s to %s...done" group new-name)
1888 new-name) 1919 new-name)
1920 (setq gnus-killed-list (delete group gnus-killed-list))
1921 (gnus-set-active group nil)
1922 (gnus-dribble-touch)
1889 (gnus-group-position-point))) 1923 (gnus-group-position-point)))
1890 1924
1891(defun gnus-group-edit-group (group &optional part) 1925(defun gnus-group-edit-group (group &optional part)
@@ -1964,6 +1998,7 @@ and NEW-NAME will be prompted for."
1964 (gnus-group-position-point))) 1998 (gnus-group-position-point)))
1965 1999
1966(defun gnus-group-make-useful-group (group method) 2000(defun gnus-group-make-useful-group (group method)
2001 "Create one of the groups described in `gnus-useful-groups'."
1967 (interactive 2002 (interactive
1968 (let ((entry (assoc (completing-read "Create group: " gnus-useful-groups 2003 (let ((entry (assoc (completing-read "Create group: " gnus-useful-groups
1969 nil t) 2004 nil t)
@@ -1979,8 +2014,7 @@ and NEW-NAME will be prompted for."
1979 "Create the Gnus documentation group." 2014 "Create the Gnus documentation group."
1980 (interactive) 2015 (interactive)
1981 (let ((name (gnus-group-prefixed-name "gnus-help" '(nndoc "gnus-help"))) 2016 (let ((name (gnus-group-prefixed-name "gnus-help" '(nndoc "gnus-help")))
1982 (file (nnheader-find-etc-directory "gnus-tut.txt" t)) 2017 (file (nnheader-find-etc-directory "gnus-tut.txt" t)))
1983 dir)
1984 (when (gnus-gethash name gnus-newsrc-hashtb) 2018 (when (gnus-gethash name gnus-newsrc-hashtb)
1985 (error "Documentation group already exists")) 2019 (error "Documentation group already exists"))
1986 (if (not file) 2020 (if (not file)
@@ -2373,7 +2407,7 @@ If REVERSE, sort in reverse order."
2373 (when (gnus-group-native-p (gnus-info-group info)) 2407 (when (gnus-group-native-p (gnus-info-group info))
2374 (gnus-info-clear-data info))) 2408 (gnus-info-clear-data info)))
2375 (gnus-get-unread-articles) 2409 (gnus-get-unread-articles)
2376 (gnus-dribble-enter "") 2410 (gnus-dribble-touch)
2377 (when (gnus-y-or-n-p 2411 (when (gnus-y-or-n-p
2378 "Move the cache away to avoid problems in the future? ") 2412 "Move the cache away to avoid problems in the future? ")
2379 (call-interactively 'gnus-cache-move-cache))))) 2413 (call-interactively 'gnus-cache-move-cache)))))
@@ -2395,16 +2429,15 @@ If REVERSE, sort in reverse order."
2395 2429
2396(defun gnus-group-catchup-current (&optional n all) 2430(defun gnus-group-catchup-current (&optional n all)
2397 "Mark all articles not marked as unread in current newsgroup as read. 2431 "Mark all articles not marked as unread in current newsgroup as read.
2398If prefix argument N is numeric, the ARG next newsgroups will be 2432If prefix argument N is numeric, the next N newsgroups will be
2399caught up. If ALL is non-nil, marked articles will also be marked as 2433caught up. If ALL is non-nil, marked articles will also be marked as
2400read. Cross references (Xref: header) of articles are ignored. 2434read. Cross references (Xref: header) of articles are ignored.
2401The difference between N and actual number of newsgroups that were 2435The number of newsgroups that this function was unable to catch
2402caught up is returned." 2436up is returned."
2403 (interactive "P") 2437 (interactive "P")
2404 (unless (gnus-group-group-name)
2405 (error "No group on the current line"))
2406 (let ((groups (gnus-group-process-prefix n)) 2438 (let ((groups (gnus-group-process-prefix n))
2407 (ret 0)) 2439 (ret 0))
2440 (unless groups (error "No groups selected"))
2408 (if (not 2441 (if (not
2409 (or (not gnus-interactive-catchup) ;Without confirmation? 2442 (or (not gnus-interactive-catchup) ;Without confirmation?
2410 gnus-expert-user 2443 gnus-expert-user
@@ -2468,7 +2501,7 @@ or nil if no action could be taken."
2468 (gnus-add-marked-articles group 'tick nil nil 'force) 2501 (gnus-add-marked-articles group 'tick nil nil 'force)
2469 (gnus-add-marked-articles group 'dormant nil nil 'force)) 2502 (gnus-add-marked-articles group 'dormant nil nil 'force))
2470 (let ((gnus-newsgroup-name group)) 2503 (let ((gnus-newsgroup-name group))
2471 (run-hooks 'gnus-group-catchup-group-hook)) 2504 (gnus-run-hooks 'gnus-group-catchup-group-hook))
2472 num)))) 2505 num))))
2473 2506
2474(defun gnus-group-expire-articles (&optional n) 2507(defun gnus-group-expire-articles (&optional n)
@@ -2592,7 +2625,7 @@ group line."
2592 'gnus-group-history))) 2625 'gnus-group-history)))
2593 (let ((newsrc (gnus-gethash group gnus-newsrc-hashtb))) 2626 (let ((newsrc (gnus-gethash group gnus-newsrc-hashtb)))
2594 (cond 2627 (cond
2595 ((string-match "^[ \t]$" group) 2628 ((string-match "^[ \t]*$" group)
2596 (error "Empty group name")) 2629 (error "Empty group name"))
2597 (newsrc 2630 (newsrc
2598 ;; Toggle subscription flag. 2631 ;; Toggle subscription flag.
@@ -2701,25 +2734,28 @@ of groups killed."
2701 (delq (assoc group gnus-newsrc-alist) 2734 (delq (assoc group gnus-newsrc-alist)
2702 gnus-newsrc-alist)) 2735 gnus-newsrc-alist))
2703 (when gnus-group-change-level-function 2736 (when gnus-group-change-level-function
2704 (funcall gnus-group-change-level-function group 9 3)) 2737 (funcall gnus-group-change-level-function
2738 group gnus-level-killed 3))
2705 (cond 2739 (cond
2706 ((setq entry (gnus-gethash group gnus-newsrc-hashtb)) 2740 ((setq entry (gnus-gethash group gnus-newsrc-hashtb))
2707 (push (cons (car entry) (nth 2 entry)) 2741 (push (cons (car entry) (nth 2 entry))
2708 gnus-list-of-killed-groups) 2742 gnus-list-of-killed-groups)
2709 (setcdr (cdr entry) (cdddr entry))) 2743 (setcdr (cdr entry) (cdddr entry)))
2710 ((member group gnus-zombie-list) 2744 ((member group gnus-zombie-list)
2711 (setq gnus-zombie-list (delete group gnus-zombie-list))))) 2745 (setq gnus-zombie-list (delete group gnus-zombie-list))))
2746 ;; There may be more than one instance displayed.
2747 (while (gnus-group-goto-group group)
2748 (gnus-delete-line)))
2712 (gnus-make-hashtable-from-newsrc-alist))) 2749 (gnus-make-hashtable-from-newsrc-alist)))
2713 2750
2714 (gnus-group-position-point) 2751 (gnus-group-position-point)
2715 (if (< (length out) 2) (car out) (nreverse out)))) 2752 (if (< (length out) 2) (car out) (nreverse out))))
2716 2753
2717(defun gnus-group-yank-group (&optional arg) 2754(defun gnus-group-yank-group (&optional arg)
2718 "Yank the last newsgroups killed with \\[gnus-group-kill-group], 2755 "Yank the last newsgroups killed with \\[gnus-group-kill-group], inserting it before the current newsgroup.
2719inserting it before the current newsgroup. The numeric ARG specifies 2756The numeric ARG specifies how many newsgroups are to be yanked. The
2720how many newsgroups are to be yanked. The name of the newsgroup yanked 2757name of the newsgroup yanked is returned, or (if several groups are
2721is returned, or (if several groups are yanked) a list of yanked groups 2758yanked) a list of yanked groups is returned."
2722is returned."
2723 (interactive "p") 2759 (interactive "p")
2724 (setq arg (or arg 1)) 2760 (setq arg (or arg 1))
2725 (let (info group prev out) 2761 (let (info group prev out)
@@ -2843,7 +2879,7 @@ entail asking the server for the groups."
2843 2879
2844(defun gnus-activate-all-groups (level) 2880(defun gnus-activate-all-groups (level)
2845 "Activate absolutely all groups." 2881 "Activate absolutely all groups."
2846 (interactive (list 7)) 2882 (interactive (list gnus-level-unsubscribed))
2847 (let ((gnus-activate-level level) 2883 (let ((gnus-activate-level level)
2848 (gnus-activate-foreign-newsgroups level)) 2884 (gnus-activate-foreign-newsgroups level))
2849 (gnus-group-get-new-news))) 2885 (gnus-group-get-new-news)))
@@ -2855,7 +2891,7 @@ re-scanning. If ARG is non-nil and not a number, this will force
2855\"hard\" re-reading of the active files from all servers." 2891\"hard\" re-reading of the active files from all servers."
2856 (interactive "P") 2892 (interactive "P")
2857 (let ((gnus-inhibit-demon t)) 2893 (let ((gnus-inhibit-demon t))
2858 (run-hooks 'gnus-get-new-news-hook) 2894 (gnus-run-hooks 'gnus-get-new-news-hook)
2859 2895
2860 ;; Read any slave files. 2896 ;; Read any slave files.
2861 (unless gnus-slave 2897 (unless gnus-slave
@@ -2882,7 +2918,7 @@ re-scanning. If ARG is non-nil and not a number, this will force
2882 (gnus-get-unread-articles arg)) 2918 (gnus-get-unread-articles arg))
2883 (let ((gnus-read-active-file (if arg nil gnus-read-active-file))) 2919 (let ((gnus-read-active-file (if arg nil gnus-read-active-file)))
2884 (gnus-get-unread-articles arg))) 2920 (gnus-get-unread-articles arg)))
2885 (run-hooks 'gnus-after-getting-new-news-hook) 2921 (gnus-run-hooks 'gnus-after-getting-new-news-hook)
2886 (gnus-group-list-groups (and (numberp arg) 2922 (gnus-group-list-groups (and (numberp arg)
2887 (max (car gnus-group-list-mode) arg))))) 2923 (max (car gnus-group-list-mode) arg)))))
2888 2924
@@ -2895,17 +2931,19 @@ If N is negative, this group and the N-1 previous groups will be checked."
2895 (ret (if (numberp n) (- n (length groups)) 0)) 2931 (ret (if (numberp n) (- n (length groups)) 0))
2896 (beg (unless n 2932 (beg (unless n
2897 (point))) 2933 (point)))
2898 group) 2934 group method)
2899 (while (setq group (pop groups)) 2935 (while (setq group (pop groups))
2900 (gnus-group-remove-mark group) 2936 (gnus-group-remove-mark group)
2901 ;; Bypass any previous denials from the server. 2937 ;; Bypass any previous denials from the server.
2902 (gnus-remove-denial (gnus-find-method-for-group group)) 2938 (gnus-remove-denial (setq method (gnus-find-method-for-group group)))
2903 (if (gnus-activate-group group (if dont-scan nil 'scan)) 2939 (if (gnus-activate-group group (if dont-scan nil 'scan))
2904 (progn 2940 (progn
2905 (gnus-get-unread-articles-in-group 2941 (gnus-get-unread-articles-in-group
2906 (gnus-get-info group) (gnus-active group) t) 2942 (gnus-get-info group) (gnus-active group) t)
2907 (unless (gnus-virtual-group-p group) 2943 (unless (gnus-virtual-group-p group)
2908 (gnus-close-group group)) 2944 (gnus-close-group group))
2945 (gnus-agent-save-group-info
2946 method (gnus-group-real-name group) (gnus-active group))
2909 (gnus-group-update-group group)) 2947 (gnus-group-update-group group))
2910 (if (eq (gnus-server-status (gnus-find-method-for-group group)) 2948 (if (eq (gnus-server-status (gnus-find-method-for-group group))
2911 'denied) 2949 'denied)
@@ -2938,8 +2976,8 @@ to use."
2938 (setq dirs (list dirs))) 2976 (setq dirs (list dirs)))
2939 (while (and (not found) 2977 (while (and (not found)
2940 (setq dir (pop dirs))) 2978 (setq dir (pop dirs)))
2941 (setq file (concat (file-name-as-directory dir) 2979 (let ((name (gnus-group-real-name group)))
2942 (gnus-group-real-name group))) 2980 (setq file (concat (file-name-as-directory dir) name)))
2943 (if (not (file-exists-p file)) 2981 (if (not (file-exists-p file))
2944 (gnus-message 1 "No such file: %s" file) 2982 (gnus-message 1 "No such file: %s" file)
2945 (let ((enable-local-variables nil)) 2983 (let ((enable-local-variables nil))
@@ -3004,6 +3042,7 @@ to use."
3004 (lambda (group) 3042 (lambda (group)
3005 (and (symbol-name group) 3043 (and (symbol-name group)
3006 (string-match regexp (symbol-name group)) 3044 (string-match regexp (symbol-name group))
3045 (symbol-value group)
3007 (push (symbol-name group) groups))) 3046 (push (symbol-name group) groups)))
3008 gnus-active-hashtb) 3047 gnus-active-hashtb)
3009 ;; Also go through all descriptions that are known to Gnus. 3048 ;; Also go through all descriptions that are known to Gnus.
@@ -3011,7 +3050,6 @@ to use."
3011 (mapatoms 3050 (mapatoms
3012 (lambda (group) 3051 (lambda (group)
3013 (and (string-match regexp (symbol-value group)) 3052 (and (string-match regexp (symbol-value group))
3014 (gnus-active (symbol-name group))
3015 (push (symbol-name group) groups))) 3053 (push (symbol-name group) groups)))
3016 gnus-description-hashtb)) 3054 gnus-description-hashtb))
3017 (if (not groups) 3055 (if (not groups)
@@ -3104,12 +3142,14 @@ group."
3104(defun gnus-group-find-new-groups (&optional arg) 3142(defun gnus-group-find-new-groups (&optional arg)
3105 "Search for new groups and add them. 3143 "Search for new groups and add them.
3106Each new group will be treated with `gnus-subscribe-newsgroup-method.' 3144Each new group will be treated with `gnus-subscribe-newsgroup-method.'
3107If ARG (the prefix), use the `ask-server' method to query 3145With 1 C-u, use the `ask-server' method to query the server for new
3108the server for new groups." 3146groups.
3109 (interactive "P") 3147With 2 C-u's, use most complete method possible to query the server
3110 (gnus-find-new-newsgroups arg) 3148for new groups, and subscribe the new groups as zombies."
3149 (interactive "p")
3150 (gnus-find-new-newsgroups (or arg 1))
3111 (gnus-group-list-groups)) 3151 (gnus-group-list-groups))
3112 3152
3113(defun gnus-group-edit-global-kill (&optional article group) 3153(defun gnus-group-edit-global-kill (&optional article group)
3114 "Edit the global kill file. 3154 "Edit the global kill file.
3115If GROUP, edit that local kill file instead." 3155If GROUP, edit that local kill file instead."
@@ -3137,18 +3177,15 @@ If GROUP, edit that local kill file instead."
3137In fact, cleanup buffers except for group mode buffer. 3177In fact, cleanup buffers except for group mode buffer.
3138The hook gnus-suspend-gnus-hook is called before actually suspending." 3178The hook gnus-suspend-gnus-hook is called before actually suspending."
3139 (interactive) 3179 (interactive)
3140 (run-hooks 'gnus-suspend-gnus-hook) 3180 (gnus-run-hooks 'gnus-suspend-gnus-hook)
3141 ;; Kill Gnus buffers except for group mode buffer. 3181 ;; Kill Gnus buffers except for group mode buffer.
3142 (let* ((group-buf (get-buffer gnus-group-buffer)) 3182 (let ((group-buf (get-buffer gnus-group-buffer)))
3143 ;; Do this on a separate list in case the user does a ^G before we finish 3183 (mapcar (lambda (buf)
3144 (gnus-buffer-list 3184 (unless (member buf (list group-buf gnus-dribble-buffer))
3145 (delete group-buf (delete gnus-dribble-buffer 3185 (kill-buffer buf)))
3146 (append gnus-buffer-list nil))))) 3186 (gnus-buffers))
3147 (while gnus-buffer-list
3148 (gnus-kill-buffer (pop gnus-buffer-list)))
3149 (gnus-kill-gnus-frames) 3187 (gnus-kill-gnus-frames)
3150 (when group-buf 3188 (when group-buf
3151 (setq gnus-buffer-list (list group-buf))
3152 (bury-buffer group-buf) 3189 (bury-buffer group-buf)
3153 (delete-windows-on group-buf t)))) 3190 (delete-windows-on group-buf t))))
3154 3191
@@ -3167,7 +3204,7 @@ The hook `gnus-exit-gnus-hook' is called before actually exiting."
3167 (not gnus-interactive-exit) ;Without confirmation 3204 (not gnus-interactive-exit) ;Without confirmation
3168 gnus-expert-user 3205 gnus-expert-user
3169 (gnus-y-or-n-p "Are you sure you want to quit reading news? ")) 3206 (gnus-y-or-n-p "Are you sure you want to quit reading news? "))
3170 (run-hooks 'gnus-exit-gnus-hook) 3207 (gnus-run-hooks 'gnus-exit-gnus-hook)
3171 ;; Offer to save data from non-quitted summary buffers. 3208 ;; Offer to save data from non-quitted summary buffers.
3172 (gnus-offer-save-summaries) 3209 (gnus-offer-save-summaries)
3173 ;; Save the newsrc file(s). 3210 ;; Save the newsrc file(s).
@@ -3177,7 +3214,7 @@ The hook `gnus-exit-gnus-hook' is called before actually exiting."
3177 ;; Reset everything. 3214 ;; Reset everything.
3178 (gnus-clear-system) 3215 (gnus-clear-system)
3179 ;; Allow the user to do things after cleaning up. 3216 ;; Allow the user to do things after cleaning up.
3180 (run-hooks 'gnus-after-exiting-gnus-hook))) 3217 (gnus-run-hooks 'gnus-after-exiting-gnus-hook)))
3181 3218
3182(defun gnus-group-quit () 3219(defun gnus-group-quit ()
3183 "Quit reading news without updating .newsrc.eld or .newsrc. 3220 "Quit reading news without updating .newsrc.eld or .newsrc.
@@ -3191,14 +3228,14 @@ The hook `gnus-exit-gnus-hook' is called before actually exiting."
3191 (gnus-yes-or-no-p 3228 (gnus-yes-or-no-p
3192 (format "Quit reading news without saving %s? " 3229 (format "Quit reading news without saving %s? "
3193 (file-name-nondirectory gnus-current-startup-file)))) 3230 (file-name-nondirectory gnus-current-startup-file))))
3194 (run-hooks 'gnus-exit-gnus-hook) 3231 (gnus-run-hooks 'gnus-exit-gnus-hook)
3195 (gnus-configure-windows 'group t) 3232 (gnus-configure-windows 'group t)
3196 (gnus-dribble-save) 3233 (gnus-dribble-save)
3197 (gnus-close-backends) 3234 (gnus-close-backends)
3198 (gnus-clear-system) 3235 (gnus-clear-system)
3199 (gnus-kill-buffer gnus-group-buffer) 3236 (gnus-kill-buffer gnus-group-buffer)
3200 ;; Allow the user to do things after cleaning up. 3237 ;; Allow the user to do things after cleaning up.
3201 (run-hooks 'gnus-after-exiting-gnus-hook))) 3238 (gnus-run-hooks 'gnus-after-exiting-gnus-hook)))
3202 3239
3203(defun gnus-group-describe-briefly () 3240(defun gnus-group-describe-briefly ()
3204 "Give a one line description of the group mode commands." 3241 "Give a one line description of the group mode commands."
@@ -3295,7 +3332,6 @@ and the second element is the address."
3295 ;; If INFO is non-nil, use that info. If FORCE is non-nil, don't 3332 ;; If INFO is non-nil, use that info. If FORCE is non-nil, don't
3296 ;; add, but replace marked articles of TYPE with ARTICLES. 3333 ;; add, but replace marked articles of TYPE with ARTICLES.
3297 (let ((info (or info (gnus-get-info group))) 3334 (let ((info (or info (gnus-get-info group)))
3298 (uncompressed '(score bookmark killed))
3299 marked m) 3335 marked m)
3300 (or (not info) 3336 (or (not info)
3301 (and (not (setq marked (nthcdr 3 info))) 3337 (and (not (setq marked (nthcdr 3 info)))
@@ -3311,7 +3347,7 @@ and the second element is the address."
3311 (if force 3347 (if force
3312 (if (null articles) 3348 (if (null articles)
3313 (setcar (nthcdr 3 info) 3349 (setcar (nthcdr 3 info)
3314 (delq (assq type (car marked)) (car marked))) 3350 (gnus-delete-alist type (car marked)))
3315 (setcdr m (gnus-compress-sequence articles t))) 3351 (setcdr m (gnus-compress-sequence articles t)))
3316 (setcdr m (gnus-compress-sequence 3352 (setcdr m (gnus-compress-sequence
3317 (sort (nconc (gnus-uncompress-range (cdr m)) 3353 (sort (nconc (gnus-uncompress-range (cdr m))
@@ -3332,7 +3368,7 @@ or `gnus-group-catchup-group-hook'."
3332 3368
3333(defsubst gnus-group-timestamp (group) 3369(defsubst gnus-group-timestamp (group)
3334 "Return the timestamp for GROUP." 3370 "Return the timestamp for GROUP."
3335 (gnus-group-get-parameter group 'timestamp)) 3371 (gnus-group-get-parameter group 'timestamp t))
3336 3372
3337(defun gnus-group-timestamp-delta (group) 3373(defun gnus-group-timestamp-delta (group)
3338 "Return the offset in seconds from the timestamp for GROUP to the current time, as a floating point number." 3374 "Return the offset in seconds from the timestamp for GROUP to the current time, as a floating point number."
diff --git a/lisp/gnus/gnus-int.el b/lisp/gnus/gnus-int.el
index b11ad1a01a0..d441a1b6287 100644
--- a/lisp/gnus/gnus-int.el
+++ b/lisp/gnus/gnus-int.el
@@ -1,7 +1,7 @@
1;;; gnus-int.el --- backend interface functions for Gnus 1;;; gnus-int.el --- backend interface functions for Gnus
2;; Copyright (C) 1996,97 Free Software Foundation, Inc. 2;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: news 5;; Keywords: news
6 6
7;; This file is part of GNU Emacs. 7;; This file is part of GNU Emacs.
@@ -27,6 +27,8 @@
27 27
28(eval-when-compile (require 'cl)) 28(eval-when-compile (require 'cl))
29 29
30(eval-when-compile (require 'cl))
31
30(require 'gnus) 32(require 'gnus)
31 33
32(defcustom gnus-open-server-hook nil 34(defcustom gnus-open-server-hook nil
@@ -86,7 +88,7 @@ If CONFIRM is non-nil, the user will be asked for an NNTP server."
86 (t 88 (t
87 (require 'nntp))) 89 (require 'nntp)))
88 (setq gnus-current-select-method gnus-select-method) 90 (setq gnus-current-select-method gnus-select-method)
89 (run-hooks 'gnus-open-server-hook) 91 (gnus-run-hooks 'gnus-open-server-hook)
90 (or 92 (or
91 ;; gnus-open-server-hook might have opened it 93 ;; gnus-open-server-hook might have opened it
92 (gnus-server-opened gnus-select-method) 94 (gnus-server-opened gnus-select-method)
@@ -121,7 +123,7 @@ If it is down, start it up (again)."
121 (gnus-message 5 "Opening %s server%s..." (car method) 123 (gnus-message 5 "Opening %s server%s..." (car method)
122 (if (equal (nth 1 method) "") "" 124 (if (equal (nth 1 method) "") ""
123 (format " on %s" (nth 1 method))))) 125 (format " on %s" (nth 1 method)))))
124 (run-hooks 'gnus-open-server-hook) 126 (gnus-run-hooks 'gnus-open-server-hook)
125 (prog1 127 (prog1
126 (gnus-open-server method) 128 (gnus-open-server method)
127 (unless silent 129 (unless silent
@@ -134,15 +136,28 @@ If it is down, start it up (again)."
134 (error "Attempted use of a nil select method")) 136 (error "Attempted use of a nil select method"))
135 (when (stringp method) 137 (when (stringp method)
136 (setq method (gnus-server-to-method method))) 138 (setq method (gnus-server-to-method method)))
137 (let ((func (intern (format "%s-%s" (car method) function)))) 139 ;; Check cache of constructed names.
138 ;; If the functions isn't bound, we require the backend in 140 (let* ((method-sym (if gnus-agent
139 ;; question. 141 (gnus-agent-get-function method)
142 (car method)))
143 (method-fns (get method-sym 'gnus-method-functions))
144 (func (let ((method-fnlist-elt (assq function method-fns)))
145 (unless method-fnlist-elt
146 (setq method-fnlist-elt
147 (cons function
148 (intern (format "%s-%s" method-sym function))))
149 (put method-sym 'gnus-method-functions
150 (cons method-fnlist-elt method-fns)))
151 (cdr method-fnlist-elt))))
152 ;; Maybe complain if there is no function.
140 (unless (fboundp func) 153 (unless (fboundp func)
154 (unless (car method)
155 (error "Trying to require a method that doesn't exist"))
141 (require (car method)) 156 (require (car method))
142 (when (and (not (fboundp func)) 157 (when (not (fboundp func))
143 (not noerror)) 158 (if noerror
144 ;; This backend doesn't implement this function. 159 (setq func nil)
145 (error "No such function: %s" func))) 160 (error "No such function: %s" func))))
146 func)) 161 func))
147 162
148 163
@@ -150,11 +165,11 @@ If it is down, start it up (again)."
150;;; Interface functions to the backends. 165;;; Interface functions to the backends.
151;;; 166;;;
152 167
153(defun gnus-open-server (method) 168(defun gnus-open-server (gnus-command-method)
154 "Open a connection to METHOD." 169 "Open a connection to GNUS-COMMAND-METHOD."
155 (when (stringp method) 170 (when (stringp gnus-command-method)
156 (setq method (gnus-server-to-method method))) 171 (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
157 (let ((elem (assoc method gnus-opened-servers))) 172 (let ((elem (assoc gnus-command-method gnus-opened-servers)))
158 ;; If this method was previously denied, we just return nil. 173 ;; If this method was previously denied, we just return nil.
159 (if (eq (nth 1 elem) 'denied) 174 (if (eq (nth 1 elem) 'denied)
160 (progn 175 (progn
@@ -162,137 +177,160 @@ If it is down, start it up (again)."
162 nil) 177 nil)
163 ;; Open the server. 178 ;; Open the server.
164 (let ((result 179 (let ((result
165 (funcall (gnus-get-function method 'open-server) 180 (funcall (gnus-get-function gnus-command-method 'open-server)
166 (nth 1 method) (nthcdr 2 method)))) 181 (nth 1 gnus-command-method)
182 (nthcdr 2 gnus-command-method))))
167 ;; If this hasn't been opened before, we add it to the list. 183 ;; If this hasn't been opened before, we add it to the list.
168 (unless elem 184 (unless elem
169 (setq elem (list method nil) 185 (setq elem (list gnus-command-method nil)
170 gnus-opened-servers (cons elem gnus-opened-servers))) 186 gnus-opened-servers (cons elem gnus-opened-servers)))
171 ;; Set the status of this server. 187 ;; Set the status of this server.
172 (setcar (cdr elem) (if result 'ok 'denied)) 188 (setcar (cdr elem) (if result 'ok 'denied))
173 ;; Return the result from the "open" call. 189 ;; Return the result from the "open" call.
174 result)))) 190 result))))
175 191
176(defun gnus-close-server (method) 192(defun gnus-close-server (gnus-command-method)
177 "Close the connection to METHOD." 193 "Close the connection to GNUS-COMMAND-METHOD."
178 (when (stringp method) 194 (when (stringp gnus-command-method)
179 (setq method (gnus-server-to-method method))) 195 (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
180 (funcall (gnus-get-function method 'close-server) (nth 1 method))) 196 (funcall (gnus-get-function gnus-command-method 'close-server)
181 197 (nth 1 gnus-command-method)))
182(defun gnus-request-list (method) 198
183 "Request the active file from METHOD." 199(defun gnus-request-list (gnus-command-method)
184 (when (stringp method) 200 "Request the active file from GNUS-COMMAND-METHOD."
185 (setq method (gnus-server-to-method method))) 201 (when (stringp gnus-command-method)
186 (funcall (gnus-get-function method 'request-list) (nth 1 method))) 202 (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
187 203 (funcall (gnus-get-function gnus-command-method 'request-list)
188(defun gnus-request-list-newsgroups (method) 204 (nth 1 gnus-command-method)))
189 "Request the newsgroups file from METHOD." 205
190 (when (stringp method) 206(defun gnus-request-list-newsgroups (gnus-command-method)
191 (setq method (gnus-server-to-method method))) 207 "Request the newsgroups file from GNUS-COMMAND-METHOD."
192 (funcall (gnus-get-function method 'request-list-newsgroups) (nth 1 method))) 208 (when (stringp gnus-command-method)
193 209 (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
194(defun gnus-request-newgroups (date method) 210 (funcall (gnus-get-function gnus-command-method 'request-list-newsgroups)
195 "Request all new groups since DATE from METHOD." 211 (nth 1 gnus-command-method)))
196 (when (stringp method) 212
197 (setq method (gnus-server-to-method method))) 213(defun gnus-request-newgroups (date gnus-command-method)
198 (let ((func (gnus-get-function method 'request-newgroups t))) 214 "Request all new groups since DATE from GNUS-COMMAND-METHOD."
215 (when (stringp gnus-command-method)
216 (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
217 (let ((func (gnus-get-function gnus-command-method 'request-newgroups t)))
199 (when func 218 (when func
200 (funcall func date (nth 1 method))))) 219 (funcall func date (nth 1 gnus-command-method)))))
201 220
202(defun gnus-server-opened (method) 221(defun gnus-server-opened (gnus-command-method)
203 "Check whether a connection to METHOD has been opened." 222 "Check whether a connection to GNUS-COMMAND-METHOD has been opened."
204 (when (stringp method) 223 (when (stringp gnus-command-method)
205 (setq method (gnus-server-to-method method))) 224 (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
206 (funcall (inline (gnus-get-function method 'server-opened)) (nth 1 method))) 225 (funcall (inline (gnus-get-function gnus-command-method 'server-opened))
207 226 (nth 1 gnus-command-method)))
208(defun gnus-status-message (method) 227
209 "Return the status message from METHOD. 228(defun gnus-status-message (gnus-command-method)
210If METHOD is a string, it is interpreted as a group name. The method 229 "Return the status message from GNUS-COMMAND-METHOD.
230If GNUS-COMMAND-METHOD is a string, it is interpreted as a group name. The method
211this group uses will be queried." 231this group uses will be queried."
212 (let ((method (if (stringp method) (gnus-find-method-for-group method) 232 (let ((gnus-command-method
213 method))) 233 (if (stringp gnus-command-method)
214 (funcall (gnus-get-function method 'status-message) (nth 1 method)))) 234 (gnus-find-method-for-group gnus-command-method)
215 235 gnus-command-method)))
216(defun gnus-request-regenerate (method) 236 (funcall (gnus-get-function gnus-command-method 'status-message)
217 "Request a data generation from METHOD." 237 (nth 1 gnus-command-method))))
218 (when (stringp method) 238
219 (setq method (gnus-server-to-method method))) 239(defun gnus-request-regenerate (gnus-command-method)
220 (funcall (gnus-get-function method 'request-regenerate) (nth 1 method))) 240 "Request a data generation from GNUS-COMMAND-METHOD."
221 241 (when (stringp gnus-command-method)
222(defun gnus-request-group (group &optional dont-check method) 242 (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
243 (funcall (gnus-get-function gnus-command-method 'request-regenerate)
244 (nth 1 gnus-command-method)))
245
246(defun gnus-request-group (group &optional dont-check gnus-command-method)
223 "Request GROUP. If DONT-CHECK, no information is required." 247 "Request GROUP. If DONT-CHECK, no information is required."
224 (let ((method (or method (inline (gnus-find-method-for-group group))))) 248 (let ((gnus-command-method
225 (when (stringp method) 249 (or gnus-command-method (inline (gnus-find-method-for-group group)))))
226 (setq method (inline (gnus-server-to-method method)))) 250 (when (stringp gnus-command-method)
227 (funcall (inline (gnus-get-function method 'request-group)) 251 (setq gnus-command-method
228 (gnus-group-real-name group) (nth 1 method) dont-check))) 252 (inline (gnus-server-to-method gnus-command-method))))
253 (funcall (inline (gnus-get-function gnus-command-method 'request-group))
254 (gnus-group-real-name group) (nth 1 gnus-command-method)
255 dont-check)))
229 256
230(defun gnus-list-active-group (group) 257(defun gnus-list-active-group (group)
231 "Request active information on GROUP." 258 "Request active information on GROUP."
232 (let ((method (gnus-find-method-for-group group)) 259 (let ((gnus-command-method (gnus-find-method-for-group group))
233 (func 'list-active-group)) 260 (func 'list-active-group))
234 (when (gnus-check-backend-function func group) 261 (when (gnus-check-backend-function func group)
235 (funcall (gnus-get-function method func) 262 (funcall (gnus-get-function gnus-command-method func)
236 (gnus-group-real-name group) (nth 1 method))))) 263 (gnus-group-real-name group) (nth 1 gnus-command-method)))))
237 264
238(defun gnus-request-group-description (group) 265(defun gnus-request-group-description (group)
239 "Request a description of GROUP." 266 "Request a description of GROUP."
240 (let ((method (gnus-find-method-for-group group)) 267 (let ((gnus-command-method (gnus-find-method-for-group group))
241 (func 'request-group-description)) 268 (func 'request-group-description))
242 (when (gnus-check-backend-function func group) 269 (when (gnus-check-backend-function func group)
243 (funcall (gnus-get-function method func) 270 (funcall (gnus-get-function gnus-command-method func)
244 (gnus-group-real-name group) (nth 1 method))))) 271 (gnus-group-real-name group) (nth 1 gnus-command-method)))))
245 272
246(defun gnus-close-group (group) 273(defun gnus-close-group (group)
247 "Request the GROUP be closed." 274 "Request the GROUP be closed."
248 (let ((method (inline (gnus-find-method-for-group group)))) 275 (let ((gnus-command-method (inline (gnus-find-method-for-group group))))
249 (funcall (gnus-get-function method 'close-group) 276 (funcall (gnus-get-function gnus-command-method 'close-group)
250 (gnus-group-real-name group) (nth 1 method)))) 277 (gnus-group-real-name group) (nth 1 gnus-command-method))))
251 278
252(defun gnus-retrieve-headers (articles group &optional fetch-old) 279(defun gnus-retrieve-headers (articles group &optional fetch-old)
253 "Request headers for ARTICLES in GROUP. 280 "Request headers for ARTICLES in GROUP.
254If FETCH-OLD, retrieve all headers (or some subset thereof) in the group." 281If FETCH-OLD, retrieve all headers (or some subset thereof) in the group."
255 (let ((method (gnus-find-method-for-group group))) 282 (let ((gnus-command-method (gnus-find-method-for-group group)))
256 (if (and gnus-use-cache (numberp (car articles))) 283 (if (and gnus-use-cache (numberp (car articles)))
257 (gnus-cache-retrieve-headers articles group fetch-old) 284 (gnus-cache-retrieve-headers articles group fetch-old)
258 (funcall (gnus-get-function method 'retrieve-headers) 285 (funcall (gnus-get-function gnus-command-method 'retrieve-headers)
259 articles (gnus-group-real-name group) (nth 1 method) 286 articles (gnus-group-real-name group)
260 fetch-old)))) 287 (nth 1 gnus-command-method) fetch-old))))
261 288
262(defun gnus-retrieve-groups (groups method) 289(defun gnus-retrieve-articles (articles group)
263 "Request active information on GROUPS from METHOD." 290 "Request ARTICLES in GROUP."
264 (when (stringp method) 291 (let ((gnus-command-method (gnus-find-method-for-group group)))
265 (setq method (gnus-server-to-method method))) 292 (funcall (gnus-get-function gnus-command-method 'retrieve-articles)
266 (funcall (gnus-get-function method 'retrieve-groups) groups (nth 1 method))) 293 articles (gnus-group-real-name group)
294 (nth 1 gnus-command-method))))
295
296(defun gnus-retrieve-groups (groups gnus-command-method)
297 "Request active information on GROUPS from GNUS-COMMAND-METHOD."
298 (when (stringp gnus-command-method)
299 (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
300 (funcall (gnus-get-function gnus-command-method 'retrieve-groups)
301 groups (nth 1 gnus-command-method)))
267 302
268(defun gnus-request-type (group &optional article) 303(defun gnus-request-type (group &optional article)
269 "Return the type (`post' or `mail') of GROUP (and ARTICLE)." 304 "Return the type (`post' or `mail') of GROUP (and ARTICLE)."
270 (let ((method (gnus-find-method-for-group group))) 305 (let ((gnus-command-method (gnus-find-method-for-group group)))
271 (if (not (gnus-check-backend-function 'request-type (car method))) 306 (if (not (gnus-check-backend-function
307 'request-type (car gnus-command-method)))
272 'unknown 308 'unknown
273 (funcall (gnus-get-function method 'request-type) 309 (funcall (gnus-get-function gnus-command-method 'request-type)
274 (gnus-group-real-name group) article)))) 310 (gnus-group-real-name group) article))))
275 311
276(defun gnus-request-update-mark (group article mark) 312(defun gnus-request-update-mark (group article mark)
277 "Return the type (`post' or `mail') of GROUP (and ARTICLE)." 313 "Allow the backend to change the mark the user tries to put on an article."
278 (let ((method (gnus-find-method-for-group group))) 314 (let ((gnus-command-method (gnus-find-method-for-group group)))
279 (if (not (gnus-check-backend-function 'request-update-mark (car method))) 315 (if (not (gnus-check-backend-function
316 'request-update-mark (car gnus-command-method)))
280 mark 317 mark
281 (funcall (gnus-get-function method 'request-update-mark) 318 (funcall (gnus-get-function gnus-command-method 'request-update-mark)
282 (gnus-group-real-name group) article mark)))) 319 (gnus-group-real-name group) article mark))))
283 320
284(defun gnus-request-article (article group &optional buffer) 321(defun gnus-request-article (article group &optional buffer)
285 "Request the ARTICLE in GROUP. 322 "Request the ARTICLE in GROUP.
286ARTICLE can either be an article number or an article Message-ID. 323ARTICLE can either be an article number or an article Message-ID.
287If BUFFER, insert the article in that group." 324If BUFFER, insert the article in that group."
288 (let ((method (gnus-find-method-for-group group))) 325 (let ((gnus-command-method (gnus-find-method-for-group group)))
289 (funcall (gnus-get-function method 'request-article) 326 (funcall (gnus-get-function gnus-command-method 'request-article)
290 article (gnus-group-real-name group) (nth 1 method) buffer))) 327 article (gnus-group-real-name group)
328 (nth 1 gnus-command-method) buffer)))
291 329
292(defun gnus-request-head (article group) 330(defun gnus-request-head (article group)
293 "Request the head of ARTICLE in GROUP." 331 "Request the head of ARTICLE in GROUP."
294 (let* ((method (gnus-find-method-for-group group)) 332 (let* ((gnus-command-method (gnus-find-method-for-group group))
295 (head (gnus-get-function method 'request-head t)) 333 (head (gnus-get-function gnus-command-method 'request-head t))
296 res clean-up) 334 res clean-up)
297 (cond 335 (cond
298 ;; Check the cache. 336 ;; Check the cache.
@@ -304,7 +342,7 @@ If BUFFER, insert the article in that group."
304 ;; Use `head' function. 342 ;; Use `head' function.
305 ((fboundp head) 343 ((fboundp head)
306 (setq res (funcall head article (gnus-group-real-name group) 344 (setq res (funcall head article (gnus-group-real-name group)
307 (nth 1 method)))) 345 (nth 1 gnus-command-method))))
308 ;; Use `article' function. 346 ;; Use `article' function.
309 (t 347 (t
310 (setq res (gnus-request-article article group) 348 (setq res (gnus-request-article article group)
@@ -320,60 +358,88 @@ If BUFFER, insert the article in that group."
320 358
321(defun gnus-request-body (article group) 359(defun gnus-request-body (article group)
322 "Request the body of ARTICLE in GROUP." 360 "Request the body of ARTICLE in GROUP."
323 (let ((method (gnus-find-method-for-group group))) 361 (let* ((gnus-command-method (gnus-find-method-for-group group))
324 (funcall (gnus-get-function method 'request-body) 362 (head (gnus-get-function gnus-command-method 'request-body t))
325 article (gnus-group-real-name group) (nth 1 method)))) 363 res clean-up)
364 (cond
365 ;; Check the cache.
366 ((and gnus-use-cache
367 (numberp article)
368 (gnus-cache-request-article article group))
369 (setq res (cons group article)
370 clean-up t))
371 ;; Use `head' function.
372 ((fboundp head)
373 (setq res (funcall head article (gnus-group-real-name group)
374 (nth 1 gnus-command-method))))
375 ;; Use `article' function.
376 (t
377 (setq res (gnus-request-article article group)
378 clean-up t)))
379 (when clean-up
380 (save-excursion
381 (set-buffer nntp-server-buffer)
382 (goto-char (point-min))
383 (when (search-forward "\n\n" nil t)
384 (delete-region (point-min) (1- (point))))))
385 res))
326 386
327(defun gnus-request-post (method) 387(defun gnus-request-post (gnus-command-method)
328 "Post the current buffer using METHOD." 388 "Post the current buffer using GNUS-COMMAND-METHOD."
329 (when (stringp method) 389 (when (stringp gnus-command-method)
330 (setq method (gnus-server-to-method method))) 390 (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
331 (funcall (gnus-get-function method 'request-post) (nth 1 method))) 391 (funcall (gnus-get-function gnus-command-method 'request-post)
332 392 (nth 1 gnus-command-method)))
333(defun gnus-request-scan (group method) 393
334 "Request a SCAN being performed in GROUP from METHOD. 394(defun gnus-request-scan (group gnus-command-method)
335If GROUP is nil, all groups on METHOD are scanned." 395 "Request a SCAN being performed in GROUP from GNUS-COMMAND-METHOD.
336 (let ((method (if group (gnus-find-method-for-group group) method)) 396If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned."
337 (gnus-inhibit-demon t)) 397 (when gnus-plugged
338 (funcall (gnus-get-function method 'request-scan) 398 (let ((gnus-command-method
339 (and group (gnus-group-real-name group)) (nth 1 method)))) 399 (if group (gnus-find-method-for-group group) gnus-command-method))
340 400 (gnus-inhibit-demon t))
341(defsubst gnus-request-update-info (info method) 401 (funcall (gnus-get-function gnus-command-method 'request-scan)
342 "Request that METHOD update INFO." 402 (and group (gnus-group-real-name group))
343 (when (stringp method) 403 (nth 1 gnus-command-method)))))
344 (setq method (gnus-server-to-method method))) 404
345 (when (gnus-check-backend-function 'request-update-info (car method)) 405(defsubst gnus-request-update-info (info gnus-command-method)
346 (funcall (gnus-get-function method 'request-update-info) 406 "Request that GNUS-COMMAND-METHOD update INFO."
407 (when (stringp gnus-command-method)
408 (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
409 (when (gnus-check-backend-function
410 'request-update-info (car gnus-command-method))
411 (funcall (gnus-get-function gnus-command-method 'request-update-info)
347 (gnus-group-real-name (gnus-info-group info)) 412 (gnus-group-real-name (gnus-info-group info))
348 info (nth 1 method)))) 413 info (nth 1 gnus-command-method))))
349 414
350(defun gnus-request-expire-articles (articles group &optional force) 415(defun gnus-request-expire-articles (articles group &optional force)
351 (let ((method (gnus-find-method-for-group group))) 416 (let ((gnus-command-method (gnus-find-method-for-group group)))
352 (funcall (gnus-get-function method 'request-expire-articles) 417 (funcall (gnus-get-function gnus-command-method 'request-expire-articles)
353 articles (gnus-group-real-name group) (nth 1 method) 418 articles (gnus-group-real-name group) (nth 1 gnus-command-method)
354 force))) 419 force)))
355 420
356(defun gnus-request-move-article 421(defun gnus-request-move-article
357 (article group server accept-function &optional last) 422 (article group server accept-function &optional last)
358 (let ((method (gnus-find-method-for-group group))) 423 (let ((gnus-command-method (gnus-find-method-for-group group)))
359 (funcall (gnus-get-function method 'request-move-article) 424 (funcall (gnus-get-function gnus-command-method 'request-move-article)
360 article (gnus-group-real-name group) 425 article (gnus-group-real-name group)
361 (nth 1 method) accept-function last))) 426 (nth 1 gnus-command-method) accept-function last)))
362 427
363(defun gnus-request-accept-article (group method &optional last) 428(defun gnus-request-accept-article (group &optional gnus-command-method last)
364 ;; Make sure there's a newline at the end of the article. 429 ;; Make sure there's a newline at the end of the article.
365 (when (stringp method) 430 (when (stringp gnus-command-method)
366 (setq method (gnus-server-to-method method))) 431 (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
367 (when (and (not method) 432 (when (and (not gnus-command-method)
368 (stringp group)) 433 (stringp group))
369 (setq method (gnus-group-name-to-method group))) 434 (setq gnus-command-method (gnus-group-name-to-method group)))
370 (goto-char (point-max)) 435 (goto-char (point-max))
371 (unless (bolp) 436 (unless (bolp)
372 (insert "\n")) 437 (insert "\n"))
373 (let ((func (car (or method (gnus-find-method-for-group group))))) 438 (let ((func (car (or gnus-command-method
439 (gnus-find-method-for-group group)))))
374 (funcall (intern (format "%s-request-accept-article" func)) 440 (funcall (intern (format "%s-request-accept-article" func))
375 (if (stringp group) (gnus-group-real-name group) group) 441 (if (stringp group) (gnus-group-real-name group) group)
376 (cadr method) 442 (cadr gnus-command-method)
377 last))) 443 last)))
378 444
379(defun gnus-request-replace-article (article group buffer) 445(defun gnus-request-replace-article (article group buffer)
@@ -382,53 +448,56 @@ If GROUP is nil, all groups on METHOD are scanned."
382 article (gnus-group-real-name group) buffer))) 448 article (gnus-group-real-name group) buffer)))
383 449
384(defun gnus-request-associate-buffer (group) 450(defun gnus-request-associate-buffer (group)
385 (let ((method (gnus-find-method-for-group group))) 451 (let ((gnus-command-method (gnus-find-method-for-group group)))
386 (funcall (gnus-get-function method 'request-associate-buffer) 452 (funcall (gnus-get-function gnus-command-method 'request-associate-buffer)
387 (gnus-group-real-name group)))) 453 (gnus-group-real-name group))))
388 454
389(defun gnus-request-restore-buffer (article group) 455(defun gnus-request-restore-buffer (article group)
390 "Request a new buffer restored to the state of ARTICLE." 456 "Request a new buffer restored to the state of ARTICLE."
391 (let ((method (gnus-find-method-for-group group))) 457 (let ((gnus-command-method (gnus-find-method-for-group group)))
392 (funcall (gnus-get-function method 'request-restore-buffer) 458 (funcall (gnus-get-function gnus-command-method 'request-restore-buffer)
393 article (gnus-group-real-name group) (nth 1 method)))) 459 article (gnus-group-real-name group)
460 (nth 1 gnus-command-method))))
394 461
395(defun gnus-request-create-group (group &optional method args) 462(defun gnus-request-create-group (group &optional gnus-command-method args)
396 (when (stringp method) 463 (when (stringp gnus-command-method)
397 (setq method (gnus-server-to-method method))) 464 (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
398 (let ((method (or method (gnus-find-method-for-group group)))) 465 (let ((gnus-command-method
399 (funcall (gnus-get-function method 'request-create-group) 466 (or gnus-command-method (gnus-find-method-for-group group))))
400 (gnus-group-real-name group) (nth 1 method) args))) 467 (funcall (gnus-get-function gnus-command-method 'request-create-group)
468 (gnus-group-real-name group) (nth 1 gnus-command-method) args)))
401 469
402(defun gnus-request-delete-group (group &optional force) 470(defun gnus-request-delete-group (group &optional force)
403 (let ((method (gnus-find-method-for-group group))) 471 (let ((gnus-command-method (gnus-find-method-for-group group)))
404 (funcall (gnus-get-function method 'request-delete-group) 472 (funcall (gnus-get-function gnus-command-method 'request-delete-group)
405 (gnus-group-real-name group) force (nth 1 method)))) 473 (gnus-group-real-name group) force (nth 1 gnus-command-method))))
406 474
407(defun gnus-request-rename-group (group new-name) 475(defun gnus-request-rename-group (group new-name)
408 (let ((method (gnus-find-method-for-group group))) 476 (let ((gnus-command-method (gnus-find-method-for-group group)))
409 (funcall (gnus-get-function method 'request-rename-group) 477 (funcall (gnus-get-function gnus-command-method 'request-rename-group)
410 (gnus-group-real-name group) 478 (gnus-group-real-name group)
411 (gnus-group-real-name new-name) (nth 1 method)))) 479 (gnus-group-real-name new-name) (nth 1 gnus-command-method))))
412 480
413(defun gnus-close-backends () 481(defun gnus-close-backends ()
414 ;; Send a close request to all backends that support such a request. 482 ;; Send a close request to all backends that support such a request.
415 (let ((methods gnus-valid-select-methods) 483 (let ((methods gnus-valid-select-methods)
416 (gnus-inhibit-demon t) 484 (gnus-inhibit-demon t)
417 func method) 485 func gnus-command-method)
418 (while (setq method (pop methods)) 486 (while (setq gnus-command-method (pop methods))
419 (when (fboundp (setq func (intern 487 (when (fboundp (setq func (intern
420 (concat (car method) "-request-close")))) 488 (concat (car gnus-command-method)
489 "-request-close"))))
421 (funcall func))))) 490 (funcall func)))))
422 491
423(defun gnus-asynchronous-p (method) 492(defun gnus-asynchronous-p (gnus-command-method)
424 (let ((func (gnus-get-function method 'asynchronous-p t))) 493 (let ((func (gnus-get-function gnus-command-method 'asynchronous-p t)))
425 (when (fboundp func) 494 (when (fboundp func)
426 (funcall func)))) 495 (funcall func))))
427 496
428(defun gnus-remove-denial (method) 497(defun gnus-remove-denial (gnus-command-method)
429 (when (stringp method) 498 (when (stringp gnus-command-method)
430 (setq method (gnus-server-to-method method))) 499 (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
431 (let* ((elem (assoc method gnus-opened-servers)) 500 (let* ((elem (assoc gnus-command-method gnus-opened-servers))
432 (status (cadr elem))) 501 (status (cadr elem)))
433 ;; If this hasn't been opened before, we add it to the list. 502 ;; If this hasn't been opened before, we add it to the list.
434 (when (eq status 'denied) 503 (when (eq status 'denied)
diff --git a/lisp/gnus/gnus-kill.el b/lisp/gnus/gnus-kill.el
index f2fad665805..3ca8b20f08f 100644
--- a/lisp/gnus/gnus-kill.el
+++ b/lisp/gnus/gnus-kill.el
@@ -1,8 +1,8 @@
1;;; gnus-kill.el --- kill commands for Gnus 1;;; gnus-kill.el --- kill commands for Gnus
2;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. 2;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> 4;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
5;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 5;; Lars Magne Ingebrigtsen <larsi@gnus.org>
6;; Keywords: news 6;; Keywords: news
7 7
8;; This file is part of GNU Emacs. 8;; This file is part of GNU Emacs.
@@ -28,6 +28,8 @@
28 28
29(eval-when-compile (require 'cl)) 29(eval-when-compile (require 'cl))
30 30
31(eval-when-compile (require 'cl))
32
31(require 'gnus) 33(require 'gnus)
32(require 'gnus-art) 34(require 'gnus-art)
33(require 'gnus-range) 35(require 'gnus-range)
@@ -159,7 +161,7 @@ gnus-kill-file-mode-hook with no arguments, if that value is non-nil."
159 (setq major-mode 'gnus-kill-file-mode) 161 (setq major-mode 'gnus-kill-file-mode)
160 (setq mode-name "Kill") 162 (setq mode-name "Kill")
161 (lisp-mode-variables nil) 163 (lisp-mode-variables nil)
162 (run-hooks 'emacs-lisp-mode-hook 'gnus-kill-file-mode-hook)) 164 (gnus-run-hooks 'emacs-lisp-mode-hook 'gnus-kill-file-mode-hook))
163 165
164(defun gnus-kill-file-edit-file (newsgroup) 166(defun gnus-kill-file-edit-file (newsgroup)
165 "Begin editing a kill file for NEWSGROUP. 167 "Begin editing a kill file for NEWSGROUP.
@@ -406,7 +408,6 @@ Returns the number of articles marked as read."
406 () 408 ()
407 (gnus-message 6 "Processing kill file %s..." (car kill-files)) 409 (gnus-message 6 "Processing kill file %s..." (car kill-files))
408 (find-file (car kill-files)) 410 (find-file (car kill-files))
409 (gnus-add-current-to-buffer-list)
410 (goto-char (point-min)) 411 (goto-char (point-min))
411 412
412 (if (consp (ignore-errors (read (current-buffer)))) 413 (if (consp (ignore-errors (read (current-buffer))))
@@ -469,9 +470,9 @@ Returns the number of articles marked as read."
469 (?h . "") 470 (?h . "")
470 (?f . "from") 471 (?f . "from")
471 (?: . "subject"))) 472 (?: . "subject")))
472 (com-to-com 473 ;;(com-to-com
473 '((?m . " ") 474 ;; '((?m . " ")
474 (?j . "X"))) 475 ;; (?j . "X")))
475 pattern modifier commands) 476 pattern modifier commands)
476 (while (not (eobp)) 477 (while (not (eobp))
477 (if (not (looking-at "[ \t]*/\\([^/]*\\)/\\([ahfcH]\\)?:\\([a-z=:]*\\)")) 478 (if (not (looking-at "[ \t]*/\\([^/]*\\)/\\([ahfcH]\\)?:\\([a-z=:]*\\)"))
@@ -566,7 +567,7 @@ COMMAND must be a lisp expression or a string representing a key sequence."
566 (not (consp (cdadr (nth 2 object)))))) 567 (not (consp (cdadr (nth 2 object))))))
567 (concat "\n" (gnus-prin1-to-string object)) 568 (concat "\n" (gnus-prin1-to-string object))
568 (save-excursion 569 (save-excursion
569 (set-buffer (get-buffer-create "*Gnus PP*")) 570 (set-buffer (gnus-get-buffer-create "*Gnus PP*"))
570 (buffer-disable-undo (current-buffer)) 571 (buffer-disable-undo (current-buffer))
571 (erase-buffer) 572 (erase-buffer)
572 (insert (format "\n(%S %S\n '(" (nth 0 object) (nth 1 object))) 573 (insert (format "\n(%S %S\n '(" (nth 0 object) (nth 1 object)))
@@ -676,10 +677,7 @@ marked as read or ticked are ignored."
676;;;###autoload 677;;;###autoload
677(defun gnus-batch-score () 678(defun gnus-batch-score ()
678 "Run batched scoring. 679 "Run batched scoring.
679Usage: emacs -batch -l gnus -f gnus-batch-score <newsgroups> ... 680Usage: emacs -batch -l ~/.emacs -l gnus -f gnus-batch-score"
680Newsgroups is a list of strings in Bnews format. If you want to score
681the comp hierarchy, you'd say \"comp.all\". If you would not like to
682score the alt hierarchy, you'd say \"!alt.all\"."
683 (interactive) 681 (interactive)
684 (let* ((gnus-newsrc-options-n 682 (let* ((gnus-newsrc-options-n
685 (gnus-newsrc-parse-options 683 (gnus-newsrc-parse-options
@@ -689,7 +687,7 @@ score the alt hierarchy, you'd say \"!alt.all\"."
689 (nnmail-spool-file nil) 687 (nnmail-spool-file nil)
690 (gnus-use-dribble-file nil) 688 (gnus-use-dribble-file nil)
691 (gnus-batch-mode t) 689 (gnus-batch-mode t)
692 group newsrc entry 690 info group newsrc entry
693 ;; Disable verbose message. 691 ;; Disable verbose message.
694 gnus-novice-user gnus-large-newsgroup 692 gnus-novice-user gnus-large-newsgroup
695 gnus-options-subscribe gnus-auto-subscribed-groups 693 gnus-options-subscribe gnus-auto-subscribed-groups
@@ -699,14 +697,13 @@ score the alt hierarchy, you'd say \"!alt.all\"."
699 (gnus-slave) 697 (gnus-slave)
700 ;; Apply kills to specified newsgroups in command line arguments. 698 ;; Apply kills to specified newsgroups in command line arguments.
701 (setq newsrc (cdr gnus-newsrc-alist)) 699 (setq newsrc (cdr gnus-newsrc-alist))
702 (while (setq group (car (pop newsrc))) 700 (while (setq info (pop newsrc))
703 (setq entry (gnus-gethash group gnus-newsrc-hashtb)) 701 (setq group (gnus-info-group info)
704 (when (and (<= (gnus-info-level (car newsrc)) gnus-level-subscribed) 702 entry (gnus-gethash group gnus-newsrc-hashtb))
703 (when (and (<= (gnus-info-level info) gnus-level-subscribed)
705 (and (car entry) 704 (and (car entry)
706 (or (eq (car entry) t) 705 (or (eq (car entry) t)
707 (not (zerop (car entry))))) 706 (not (zerop (car entry))))))
708 ;;(eq (gnus-matches-options-n group) 'subscribe)
709 )
710 (gnus-summary-read-group group nil t nil t) 707 (gnus-summary-read-group group nil t nil t)
711 (when (eq (current-buffer) (get-buffer gnus-summary-buffer)) 708 (when (eq (current-buffer) (get-buffer gnus-summary-buffer))
712 (gnus-summary-exit)))) 709 (gnus-summary-exit))))
diff --git a/lisp/gnus/gnus-logic.el b/lisp/gnus/gnus-logic.el
index 106fde52c81..a6028352bf5 100644
--- a/lisp/gnus/gnus-logic.el
+++ b/lisp/gnus/gnus-logic.el
@@ -1,7 +1,7 @@
1;;; gnus-logic.el --- advanced scoring code for Gnus 1;;; gnus-logic.el --- advanced scoring code for Gnus
2;; Copyright (C) 1996,97 Free Software Foundation, Inc. 2;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: news 5;; Keywords: news
6 6
7;; This file is part of GNU Emacs. 7;; This file is part of GNU Emacs.
@@ -27,6 +27,8 @@
27 27
28(eval-when-compile (require 'cl)) 28(eval-when-compile (require 'cl))
29 29
30(eval-when-compile (require 'cl))
31
30(require 'gnus) 32(require 'gnus)
31(require 'gnus-score) 33(require 'gnus-score)
32(require 'gnus-util) 34(require 'gnus-util)
@@ -164,9 +166,9 @@
164 (funcall type match (or (aref gnus-advanced-headers index) 0)))) 166 (funcall type match (or (aref gnus-advanced-headers index) 0))))
165 167
166(defun gnus-advanced-date (index match type) 168(defun gnus-advanced-date (index match type)
167 (let ((date (encode-time (parse-time-string 169 (let ((date (apply 'encode-time (parse-time-string
168 (aref gnus-advanced-headers index)))) 170 (aref gnus-advanced-headers index))))
169 (match (encode-time (parse-time-string match)))) 171 (match (apply 'encode-time (parse-time-string match))))
170 (cond 172 (cond
171 ((eq type 'at) 173 ((eq type 'at)
172 (equal date match)) 174 (equal date match))
diff --git a/lisp/gnus/gnus-mh.el b/lisp/gnus/gnus-mh.el
index 0cf74b11e9d..fa01f5aa074 100644
--- a/lisp/gnus/gnus-mh.el
+++ b/lisp/gnus/gnus-mh.el
@@ -1,8 +1,8 @@
1;;; gnus-mh.el --- mh-e interface for Gnus 1;;; gnus-mh.el --- mh-e interface for Gnus
2;; Copyright (C) 1994,95,96,97 Free Software Foundation, Inc. 2;; Copyright (C) 1994,95,96,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> 4;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
5;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 5;; Lars Magne Ingebrigtsen <larsi@gnus.org>
6;; Keywords: news 6;; Keywords: news
7 7
8;; This file is part of GNU Emacs. 8;; This file is part of GNU Emacs.
@@ -64,7 +64,7 @@ Optional argument FOLDER specifies folder name."
64 (funcall gnus-folder-save-name gnus-newsgroup-name 64 (funcall gnus-folder-save-name gnus-newsgroup-name
65 gnus-current-headers gnus-newsgroup-last-folder) 65 gnus-current-headers gnus-newsgroup-last-folder)
66 t)))) 66 t))))
67 (errbuf (get-buffer-create " *Gnus rcvstore*")) 67 (errbuf (gnus-get-buffer-create " *Gnus rcvstore*"))
68 ;; Find the rcvstore program. 68 ;; Find the rcvstore program.
69 (exec-path (if mh-lib (cons mh-lib exec-path) exec-path))) 69 (exec-path (if mh-lib (cons mh-lib exec-path) exec-path)))
70 (gnus-eval-in-buffer-window gnus-original-article-buffer 70 (gnus-eval-in-buffer-window gnus-original-article-buffer
diff --git a/lisp/gnus/gnus-move.el b/lisp/gnus/gnus-move.el
index f00fb3b5ac1..b461952185e 100644
--- a/lisp/gnus/gnus-move.el
+++ b/lisp/gnus/gnus-move.el
@@ -1,7 +1,7 @@
1;;; gnus-move.el --- commands for moving Gnus from one server to another 1;;; gnus-move.el --- commands for moving Gnus from one server to another
2;; Copyright (C) 1996,97 Free Software Foundation, Inc. 2;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: news 5;; Keywords: news
6 6
7;; This file is part of GNU Emacs. 7;; This file is part of GNU Emacs.
@@ -27,6 +27,8 @@
27 27
28(eval-when-compile (require 'cl)) 28(eval-when-compile (require 'cl))
29 29
30(eval-when-compile (require 'cl))
31
30(require 'gnus) 32(require 'gnus)
31(require 'gnus-start) 33(require 'gnus-start)
32(require 'gnus-int) 34(require 'gnus-int)
@@ -113,24 +115,27 @@ Update the .newsrc.eld file to reflect the change of nntp server."
113 (goto-char (point-min)) 115 (goto-char (point-min))
114 (while (looking-at 116 (while (looking-at
115 "^[0-9]+\t[^\t]*\t[^\t]*\t[^\t]*\t\\([^\t]*\\)\t") 117 "^[0-9]+\t[^\t]*\t[^\t]*\t[^\t]*\t\\([^\t]*\\)\t")
116 (setq to-article 118 (when (setq to-article
117 (gnus-gethash 119 (gnus-gethash
118 (buffer-substring (match-beginning 1) (match-end 1)) 120 (buffer-substring (match-beginning 1) (match-end 1))
119 hashtb)) 121 hashtb))
120 ;; Add this article to the list of read articles. 122 ;; Add this article to the list of read articles.
121 (push to-article to-reads) 123 (push to-article to-reads)
122 ;; See if there are any marks and then add them. 124 ;; See if there are any marks and then add them.
123 (when (setq mark (assq (read (current-buffer)) marks)) 125 (when (setq mark (assq (read (current-buffer)) marks))
124 (setq marks (delq mark marks)) 126 (setq marks (delq mark marks))
125 (setcar mark to-article) 127 (setcar mark to-article)
126 (push mark to-marks)) 128 (push mark to-marks))
127 (forward-line 1)) 129 (forward-line 1)))
128 ;; Now we know what the read articles are and what the 130 ;; Now we know what the read articles are and what the
129 ;; article marks are. We transform the information 131 ;; article marks are. We transform the information
130 ;; into the Gnus info format. 132 ;; into the Gnus info format.
131 (setq to-reads 133 (setq to-reads
132 (gnus-range-add 134 (gnus-range-add
133 (gnus-compress-sequence (and to-reads (sort to-reads '<)) t) 135 (gnus-compress-sequence
136 (and (setq to-reads (delq nil to-reads))
137 (sort to-reads '<))
138 t)
134 (cons 1 (1- (car to-active))))) 139 (cons 1 (1- (car to-active)))))
135 (gnus-info-set-read info to-reads) 140 (gnus-info-set-read info to-reads)
136 ;; Do the marks. I'm sure y'all understand what's 141 ;; Do the marks. I'm sure y'all understand what's
diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el
index fc94bb2d2a8..23653e54e14 100644
--- a/lisp/gnus/gnus-msg.el
+++ b/lisp/gnus/gnus-msg.el
@@ -1,8 +1,8 @@
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 Free Software Foundation, Inc. 2;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> 4;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
5;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 5;; Lars Magne Ingebrigtsen <larsi@gnus.org>
6;; Keywords: news 6;; Keywords: news
7 7
8;; This file is part of GNU Emacs. 8;; This file is part of GNU Emacs.
@@ -28,23 +28,32 @@
28 28
29(eval-when-compile (require 'cl)) 29(eval-when-compile (require 'cl))
30 30
31(eval-when-compile (require 'cl))
32
31(require 'gnus) 33(require 'gnus)
32(require 'gnus-ems) 34(require 'gnus-ems)
33(require 'message) 35(require 'message)
34(require 'gnus-art) 36(require 'gnus-art)
35 37
36;; Added by Sudish Joseph <joseph@cis.ohio-state.edu>. 38(defcustom gnus-post-method nil
37(defvar gnus-post-method nil
38 "*Preferred method for posting USENET news. 39 "*Preferred method for posting USENET news.
39If this variable is nil, Gnus will use the current method to decide
40which method to use when posting. If it is non-nil, it will override
41the current method. This method will not be used in mail groups and
42the like, only in \"real\" newsgroups.
43 40
44The value must be a valid method as discussed in the documentation of 41If this variable is `current', Gnus will use the \"current\" select
45`gnus-select-method'. It can also be a list of methods. If that is 42method when posting. If it is nil (which is the default), Gnus will
46the case, the user will be queried for what select method to use when 43use the native posting method of the server.
47posting.") 44
45This method will not be used in mail groups and the like, only in
46\"real\" newsgroups.
47
48If 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
50methods. If that is the case, the user will be queried for what select
51method to use when posting."
52 :group 'gnus-group-foreign
53 :type `(choice (const nil)
54 (const current)
55 (const native)
56 (sexp :tag "Methods" ,gnus-select-method)))
48 57
49(defvar gnus-outgoing-message-group nil 58(defvar gnus-outgoing-message-group nil
50 "*All outgoing messages will be put in this group. 59 "*All outgoing messages will be put in this group.
@@ -66,13 +75,6 @@ the group.")
66(defvar gnus-add-to-list nil 75(defvar gnus-add-to-list nil
67 "*If non-nil, add a `to-list' parameter automatically.") 76 "*If non-nil, add a `to-list' parameter automatically.")
68 77
69(defvar gnus-sent-message-ids-file
70 (nnheader-concat gnus-directory "Sent-Message-IDs")
71 "File where Gnus saves a cache of sent message ids.")
72
73(defvar gnus-sent-message-ids-length 1000
74 "The number of sent Message-IDs to save.")
75
76(defvar gnus-crosspost-complaint 78(defvar gnus-crosspost-complaint
77 "Hi, 79 "Hi,
78 80
@@ -94,11 +96,29 @@ the second with the current group name.")
94(defvar gnus-message-setup-hook nil 96(defvar gnus-message-setup-hook nil
95 "Hook run after setting up a message buffer.") 97 "Hook run after setting up a message buffer.")
96 98
99(defvar gnus-bug-create-help-buffer t
100 "*Should we create the *Gnus Help Bug* buffer?")
101
102(defvar gnus-posting-styles nil
103 "*Alist of styles to use when posting.")
104
105(defvar gnus-posting-style-alist
106 '((organization . message-user-organization)
107 (signature . message-signature)
108 (signature-file . message-signature-file)
109 (address . user-mail-address)
110 (name . user-full-name))
111 "*Mapping from style parameters to variables.")
112
97;;; Internal variables. 113;;; Internal variables.
98 114
115(defvar gnus-inhibit-posting-styles nil
116 "Inhibit the use of posting styles.")
117
99(defvar gnus-message-buffer "*Mail Gnus*") 118(defvar gnus-message-buffer "*Mail Gnus*")
100(defvar gnus-article-copy nil) 119(defvar gnus-article-copy nil)
101(defvar gnus-last-posting-server nil) 120(defvar gnus-last-posting-server nil)
121(defvar gnus-message-group-art nil)
102 122
103(defconst gnus-bug-message 123(defconst gnus-bug-message
104 "Sending a bug report to the Gnus Towers. 124 "Sending a bug report to the Gnus Towers.
@@ -161,22 +181,30 @@ Thank you for your help in stamping out bugs.
161 181
162(defvar gnus-article-reply nil) 182(defvar gnus-article-reply nil)
163(defmacro gnus-setup-message (config &rest forms) 183(defmacro gnus-setup-message (config &rest forms)
164 (let ((winconf (make-symbol "winconf")) 184 (let ((winconf (make-symbol "gnus-setup-message-winconf"))
165 (buffer (make-symbol "buffer")) 185 (buffer (make-symbol "gnus-setup-message-buffer"))
166 (article (make-symbol "article"))) 186 (article (make-symbol "gnus-setup-message-article"))
187 (group (make-symbol "gnus-setup-message-group")))
167 `(let ((,winconf (current-window-configuration)) 188 `(let ((,winconf (current-window-configuration))
168 (,buffer (buffer-name (current-buffer))) 189 (,buffer (buffer-name (current-buffer)))
169 (,article (and gnus-article-reply (gnus-summary-article-number))) 190 (,article (and gnus-article-reply (gnus-summary-article-number)))
191 (,group gnus-newsgroup-name)
170 (message-header-setup-hook 192 (message-header-setup-hook
171 (copy-sequence message-header-setup-hook))) 193 (copy-sequence message-header-setup-hook))
194 (message-mode-hook (copy-sequence message-mode-hook)))
172 (add-hook 'message-header-setup-hook 'gnus-inews-insert-gcc) 195 (add-hook 'message-header-setup-hook 'gnus-inews-insert-gcc)
173 (add-hook 'message-header-setup-hook 'gnus-inews-insert-archive-gcc) 196 (add-hook 'message-header-setup-hook 'gnus-inews-insert-archive-gcc)
197 (add-hook 'message-mode-hook 'gnus-configure-posting-styles)
174 (unwind-protect 198 (unwind-protect
175 ,@forms 199 (progn
200 ,@forms)
176 (gnus-inews-add-send-actions ,winconf ,buffer ,article) 201 (gnus-inews-add-send-actions ,winconf ,buffer ,article)
177 (setq gnus-message-buffer (current-buffer)) 202 (setq gnus-message-buffer (current-buffer))
203 (set (make-local-variable 'gnus-message-group-art)
204 (cons ,group ,article))
178 (make-local-variable 'gnus-newsgroup-name) 205 (make-local-variable 'gnus-newsgroup-name)
179 (run-hooks 'gnus-message-setup-hook)) 206 (gnus-run-hooks 'gnus-message-setup-hook))
207 (gnus-add-buffer)
180 (gnus-configure-windows ,config t) 208 (gnus-configure-windows ,config t)
181 (set-buffer-modified-p nil)))) 209 (set-buffer-modified-p nil))))
182 210
@@ -190,9 +218,9 @@ Thank you for your help in stamping out bugs.
190 (message-add-action 218 (message-add-action
191 `(set-window-configuration ,winconf) 'exit 'postpone 'kill) 219 `(set-window-configuration ,winconf) 'exit 'postpone 'kill)
192 (message-add-action 220 (message-add-action
193 `(when (buffer-name (get-buffer ,buffer)) 221 `(when (gnus-buffer-exists-p ,buffer)
194 (save-excursion 222 (save-excursion
195 (set-buffer (get-buffer ,buffer)) 223 (set-buffer ,buffer)
196 ,(when article 224 ,(when article
197 `(gnus-summary-mark-article-as-replied ,article)))) 225 `(gnus-summary-mark-article-as-replied ,article))))
198 'send)) 226 'send))
@@ -213,8 +241,7 @@ Thank you for your help in stamping out bugs.
213If ARG, post to the group under point. 241If ARG, post to the group under point.
214If ARG is 1, prompt for a group name." 242If ARG is 1, prompt for a group name."
215 (interactive "P") 243 (interactive "P")
216 ;; Bind this variable here to make message mode hooks 244 ;; Bind this variable here to make message mode hooks work ok.
217 ;; work ok.
218 (let ((gnus-newsgroup-name 245 (let ((gnus-newsgroup-name
219 (if arg 246 (if arg
220 (if (= 1 (prefix-numeric-value arg)) 247 (if (= 1 (prefix-numeric-value arg))
@@ -227,7 +254,6 @@ If ARG is 1, prompt for a group name."
227(defun gnus-summary-post-news () 254(defun gnus-summary-post-news ()
228 "Start composing a news message." 255 "Start composing a news message."
229 (interactive) 256 (interactive)
230 (gnus-set-global-variables)
231 (gnus-post-news 'post gnus-newsgroup-name)) 257 (gnus-post-news 'post gnus-newsgroup-name))
232 258
233(defun gnus-summary-followup (yank &optional force-news) 259(defun gnus-summary-followup (yank &optional force-news)
@@ -236,7 +262,6 @@ If prefix argument YANK is non-nil, original article is yanked automatically."
236 (interactive 262 (interactive
237 (list (and current-prefix-arg 263 (list (and current-prefix-arg
238 (gnus-summary-work-articles 1)))) 264 (gnus-summary-work-articles 1))))
239 (gnus-set-global-variables)
240 (when yank 265 (when yank
241 (gnus-summary-goto-subject (car yank))) 266 (gnus-summary-goto-subject (car yank)))
242 (save-window-excursion 267 (save-window-excursion
@@ -283,14 +308,16 @@ If prefix argument YANK is non-nil, original article is yanked automatically."
283 (push-mark) 308 (push-mark)
284 (goto-char beg))) 309 (goto-char beg)))
285 310
286(defun gnus-summary-cancel-article (n) 311(defun gnus-summary-cancel-article (&optional n symp)
287 "Cancel an article you posted." 312 "Cancel an article you posted.
288 (interactive "P") 313Uses the process-prefix convention. If given the symbolic
289 (gnus-set-global-variables) 314prefix `a', cancel using the standard posting method; if not
315post using the current select method."
316 (interactive (gnus-interactive "P\ny"))
290 (let ((articles (gnus-summary-work-articles n)) 317 (let ((articles (gnus-summary-work-articles n))
291 (message-post-method 318 (message-post-method
292 `(lambda (arg) 319 `(lambda (arg)
293 (gnus-post-method nil ,gnus-newsgroup-name))) 320 (gnus-post-method (not (eq symp 'a)) ,gnus-newsgroup-name)))
294 article) 321 article)
295 (while (setq article (pop articles)) 322 (while (setq article (pop articles))
296 (when (gnus-summary-select-article t nil nil article) 323 (when (gnus-summary-select-article t nil nil article)
@@ -306,7 +333,6 @@ If prefix argument YANK is non-nil, original article is yanked automatically."
306This is done simply by taking the old article and adding a Supersedes 333This is done simply by taking the old article and adding a Supersedes
307header line with the old Message-ID." 334header line with the old Message-ID."
308 (interactive) 335 (interactive)
309 (gnus-set-global-variables)
310 (let ((article (gnus-summary-article-number))) 336 (let ((article (gnus-summary-article-number)))
311 (gnus-setup-message 'reply-yank 337 (gnus-setup-message 'reply-yank
312 (gnus-summary-select-article t) 338 (gnus-summary-select-article t)
@@ -314,9 +340,9 @@ header line with the old Message-ID."
314 (message-supersede) 340 (message-supersede)
315 (push 341 (push
316 `((lambda () 342 `((lambda ()
317 (when (buffer-name (get-buffer ,gnus-summary-buffer)) 343 (when (gnus-buffer-exists-p ,gnus-summary-buffer)
318 (save-excursion 344 (save-excursion
319 (set-buffer (get-buffer ,gnus-summary-buffer)) 345 (set-buffer ,gnus-summary-buffer)
320 (gnus-cache-possibly-remove-article ,article nil nil nil t) 346 (gnus-cache-possibly-remove-article ,article nil nil nil t)
321 (gnus-summary-mark-as-read ,article gnus-canceled-mark))))) 347 (gnus-summary-mark-as-read ,article gnus-canceled-mark)))))
322 message-send-actions)))) 348 message-send-actions))))
@@ -328,14 +354,12 @@ header line with the old Message-ID."
328 ;; this copy is in the buffer gnus-article-copy. 354 ;; this copy is in the buffer gnus-article-copy.
329 ;; if ARTICLE-BUFFER is nil, gnus-article-buffer is used 355 ;; if ARTICLE-BUFFER is nil, gnus-article-buffer is used
330 ;; this buffer should be passed to all mail/news reply/post routines. 356 ;; this buffer should be passed to all mail/news reply/post routines.
331 (setq gnus-article-copy (get-buffer-create " *gnus article copy*")) 357 (setq gnus-article-copy (gnus-get-buffer-create " *gnus article copy*"))
332 (buffer-disable-undo gnus-article-copy) 358 (buffer-disable-undo gnus-article-copy)
333 (or (memq gnus-article-copy gnus-buffer-list)
334 (push gnus-article-copy gnus-buffer-list))
335 (let ((article-buffer (or article-buffer gnus-article-buffer)) 359 (let ((article-buffer (or article-buffer gnus-article-buffer))
336 end beg contents) 360 end beg)
337 (if (not (and (get-buffer article-buffer) 361 (if (not (and (get-buffer article-buffer)
338 (buffer-name (get-buffer article-buffer)))) 362 (gnus-buffer-exists-p article-buffer)))
339 (error "Can't find any article buffer") 363 (error "Can't find any article buffer")
340 (save-excursion 364 (save-excursion
341 (set-buffer article-buffer) 365 (set-buffer article-buffer)
@@ -404,6 +428,7 @@ header line with the old Message-ID."
404 (if post 428 (if post
405 (message-news (or to-group group)) 429 (message-news (or to-group group))
406 (set-buffer gnus-article-copy) 430 (set-buffer gnus-article-copy)
431 (gnus-msg-treat-broken-reply-to)
407 (message-followup (if (or newsgroup-p force-news) nil to-group))) 432 (message-followup (if (or newsgroup-p force-news) nil to-group)))
408 ;; The is mail. 433 ;; The is mail.
409 (if post 434 (if post
@@ -417,12 +442,19 @@ header line with the old Message-ID."
417 (push (list 'gnus-inews-add-to-address pgroup) 442 (push (list 'gnus-inews-add-to-address pgroup)
418 message-send-actions))) 443 message-send-actions)))
419 (set-buffer gnus-article-copy) 444 (set-buffer gnus-article-copy)
420 (message-wide-reply to-address 445 (gnus-msg-treat-broken-reply-to)
421 (gnus-group-find-parameter 446 (message-wide-reply to-address)))
422 gnus-newsgroup-name 'broken-reply-to))))
423 (when yank 447 (when yank
424 (gnus-inews-yank-articles yank)))))) 448 (gnus-inews-yank-articles yank))))))
425 449
450(defun gnus-msg-treat-broken-reply-to ()
451 "Remove the Reply-to header iff broken-reply-to."
452 (when (gnus-group-find-parameter
453 gnus-newsgroup-name 'broken-reply-to)
454 (save-restriction
455 (message-narrow-to-head)
456 (message-remove-header "reply-to"))))
457
426(defun gnus-post-method (arg group &optional silent) 458(defun gnus-post-method (arg group &optional silent)
427 "Return the posting method based on GROUP and ARG. 459 "Return the posting method based on GROUP and ARG.
428If SILENT, don't prompt the user." 460If SILENT, don't prompt the user."
@@ -431,22 +463,28 @@ If SILENT, don't prompt the user."
431 ;; If the group-method is nil (which shouldn't happen) we use 463 ;; If the group-method is nil (which shouldn't happen) we use
432 ;; the default method. 464 ;; the default method.
433 ((null group-method) 465 ((null group-method)
434 (or gnus-post-method gnus-select-method message-post-method)) 466 (or (and (null (eq gnus-post-method 'active)) gnus-post-method)
435 ;; We want this group's method. 467 gnus-select-method message-post-method))
468 ;; We want the inverse of the default
436 ((and arg (not (eq arg 0))) 469 ((and arg (not (eq arg 0)))
437 group-method) 470 (if (eq gnus-post-method 'active)
471 gnus-select-method
472 group-method))
438 ;; We query the user for a post method. 473 ;; We query the user for a post method.
439 ((or arg 474 ((or arg
440 (and gnus-post-method 475 (and gnus-post-method
476 (not (eq gnus-post-method 'current))
441 (listp (car gnus-post-method)))) 477 (listp (car gnus-post-method))))
442 (let* ((methods 478 (let* ((methods
443 ;; Collect all methods we know about. 479 ;; Collect all methods we know about.
444 (append 480 (append
445 (when gnus-post-method 481 (when (and gnus-post-method
482 (not (eq gnus-post-method 'current)))
446 (if (listp (car gnus-post-method)) 483 (if (listp (car gnus-post-method))
447 gnus-post-method 484 gnus-post-method
448 (list gnus-post-method))) 485 (list gnus-post-method)))
449 gnus-secondary-select-methods 486 gnus-secondary-select-methods
487 (mapcar 'cdr gnus-server-alist)
450 (list gnus-select-method) 488 (list gnus-select-method)
451 (list group-method))) 489 (list group-method)))
452 method-alist post-methods method) 490 method-alist post-methods method)
@@ -475,41 +513,16 @@ If SILENT, don't prompt the user."
475 (cons (or gnus-last-posting-server "") 0)))) 513 (cons (or gnus-last-posting-server "") 0))))
476 method-alist)))) 514 method-alist))))
477 ;; Override normal method. 515 ;; Override normal method.
478 (gnus-post-method 516 ((and (eq gnus-post-method 'current)
517 (not (eq (car group-method) 'nndraft))
518 (not arg))
519 group-method)
520 ((and gnus-post-method
521 (not (eq gnus-post-method 'current)))
479 gnus-post-method) 522 gnus-post-method)
480 ;; Use the normal select method. 523 ;; Use the normal select method.
481 (t gnus-select-method)))) 524 (t gnus-select-method))))
482 525
483;;;
484;;; Check whether the message has been sent already.
485;;;
486
487(defvar gnus-inews-sent-ids nil)
488
489(defun gnus-inews-reject-message ()
490 "Check whether this message has already been sent."
491 (when gnus-sent-message-ids-file
492 (let ((message-id (save-restriction (message-narrow-to-headers)
493 (mail-fetch-field "message-id")))
494 end)
495 (when message-id
496 (unless gnus-inews-sent-ids
497 (ignore-errors
498 (load t t t)))
499 (if (member message-id gnus-inews-sent-ids)
500 ;; Reject this message.
501 (not (gnus-yes-or-no-p
502 (format "Message %s already sent. Send anyway? "
503 message-id)))
504 (push message-id gnus-inews-sent-ids)
505 ;; Chop off the last Message-IDs.
506 (when (setq end (nthcdr gnus-sent-message-ids-length
507 gnus-inews-sent-ids))
508 (setcdr end nil))
509 (nnheader-temp-write gnus-sent-message-ids-file
510 (gnus-prin1 `(setq gnus-inews-sent-ids ',gnus-inews-sent-ids)))
511 nil)))))
512
513 526
514 527
515;; Dummy to avoid byte-compile warning. 528;; Dummy to avoid byte-compile warning.
@@ -520,7 +533,7 @@ If SILENT, don't prompt the user."
520;;; as well include the Emacs version as well. 533;;; as well include the Emacs version as well.
521;;; The following function works with later GNU Emacs, and XEmacs. 534;;; The following function works with later GNU Emacs, and XEmacs.
522(defun gnus-extended-version () 535(defun gnus-extended-version ()
523 "Stringified Gnus version and Emacs version" 536 "Stringified Gnus version and Emacs version."
524 (interactive) 537 (interactive)
525 (concat 538 (concat
526 gnus-version 539 gnus-version
@@ -547,6 +560,8 @@ If SILENT, don't prompt the user."
547 560
548;; Written by "Mr. Per Persson" <pp@gnu.ai.mit.edu>. 561;; Written by "Mr. Per Persson" <pp@gnu.ai.mit.edu>.
549(defun gnus-inews-insert-mime-headers () 562(defun gnus-inews-insert-mime-headers ()
563 "Insert MIME headers.
564Assumes ISO-Latin-1 is used iff 8-bit characters are present."
550 (goto-char (point-min)) 565 (goto-char (point-min))
551 (let ((mail-header-separator 566 (let ((mail-header-separator
552 (progn 567 (progn
@@ -561,7 +576,7 @@ If SILENT, don't prompt the user."
561 (cond ((save-restriction 576 (cond ((save-restriction
562 (widen) 577 (widen)
563 (goto-char (point-min)) 578 (goto-char (point-min))
564 (re-search-forward "[\200-\377]" nil t)) 579 (re-search-forward "[^\000-\177]" nil t))
565 (or (mail-position-on-field "Content-Type") 580 (or (mail-position-on-field "Content-Type")
566 (insert "text/plain; charset=ISO-8859-1")) 581 (insert "text/plain; charset=ISO-8859-1"))
567 (or (mail-position-on-field "Content-Transfer-Encoding") 582 (or (mail-position-on-field "Content-Transfer-Encoding")
@@ -571,6 +586,8 @@ If SILENT, don't prompt the user."
571 (or (mail-position-on-field "Content-Transfer-Encoding") 586 (or (mail-position-on-field "Content-Transfer-Encoding")
572 (insert "7bit"))))))) 587 (insert "7bit")))))))
573 588
589(custom-add-option 'message-header-hook 'gnus-inews-insert-mime-headers)
590
574 591
575;;; 592;;;
576;;; Gnus Mail Functions 593;;; Gnus Mail Functions
@@ -586,15 +603,14 @@ automatically."
586 (list (and current-prefix-arg 603 (list (and current-prefix-arg
587 (gnus-summary-work-articles 1)))) 604 (gnus-summary-work-articles 1))))
588 ;; Stripping headers should be specified with mail-yank-ignored-headers. 605 ;; Stripping headers should be specified with mail-yank-ignored-headers.
589 (gnus-set-global-variables)
590 (when yank 606 (when yank
591 (gnus-summary-goto-subject (car yank))) 607 (gnus-summary-goto-subject (car yank)))
592 (let ((gnus-article-reply t)) 608 (let ((gnus-article-reply t))
593 (gnus-setup-message (if yank 'reply-yank 'reply) 609 (gnus-setup-message (if yank 'reply-yank 'reply)
594 (gnus-summary-select-article) 610 (gnus-summary-select-article)
595 (set-buffer (gnus-copy-article-buffer)) 611 (set-buffer (gnus-copy-article-buffer))
596 (message-reply nil wide (gnus-group-find-parameter 612 (gnus-msg-treat-broken-reply-to)
597 gnus-newsgroup-name 'broken-reply-to)) 613 (message-reply nil wide)
598 (when yank 614 (when yank
599 (gnus-inews-yank-articles yank))))) 615 (gnus-inews-yank-articles yank)))))
600 616
@@ -623,7 +639,6 @@ The original article will be yanked."
623 "Forward the current message to another user. 639 "Forward the current message to another user.
624If FULL-HEADERS (the prefix), include full headers when forwarding." 640If FULL-HEADERS (the prefix), include full headers when forwarding."
625 (interactive "P") 641 (interactive "P")
626 (gnus-set-global-variables)
627 (gnus-setup-message 'forward 642 (gnus-setup-message 'forward
628 (gnus-summary-select-article) 643 (gnus-summary-select-article)
629 (set-buffer gnus-original-article-buffer) 644 (set-buffer gnus-original-article-buffer)
@@ -696,8 +711,7 @@ The current group name will be inserted at \"%s\".")
696 (message-goto-subject) 711 (message-goto-subject)
697 (re-search-forward " *$") 712 (re-search-forward " *$")
698 (replace-match " (crosspost notification)" t t) 713 (replace-match " (crosspost notification)" t t)
699 (when (fboundp 'deactivate-mark) 714 (gnus-deactivate-mark)
700 (deactivate-mark))
701 (when (gnus-y-or-n-p "Send this complaint? ") 715 (when (gnus-y-or-n-p "Send this complaint? ")
702 (message-send-and-exit))))))) 716 (message-send-and-exit)))))))
703 717
@@ -801,18 +815,20 @@ If YANK is non-nil, include the original article."
801 (error "Gnus has been shut down")) 815 (error "Gnus has been shut down"))
802 (gnus-setup-message 'bug 816 (gnus-setup-message 'bug
803 (delete-other-windows) 817 (delete-other-windows)
804 (switch-to-buffer "*Gnus Help Bug*") 818 (when gnus-bug-create-help-buffer
805 (erase-buffer) 819 (switch-to-buffer "*Gnus Help Bug*")
806 (insert gnus-bug-message) 820 (erase-buffer)
807 (goto-char (point-min)) 821 (insert gnus-bug-message)
822 (goto-char (point-min)))
808 (message-pop-to-buffer "*Gnus Bug*") 823 (message-pop-to-buffer "*Gnus Bug*")
809 (message-setup `((To . ,gnus-maintainer) (Subject . ""))) 824 (message-setup `((To . ,gnus-maintainer) (Subject . "")))
810 (push `(gnus-bug-kill-buffer) message-send-actions) 825 (when gnus-bug-create-help-buffer
826 (push `(gnus-bug-kill-buffer) message-send-actions))
811 (goto-char (point-min)) 827 (goto-char (point-min))
812 (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$")) 828 (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$"))
813 (forward-line 1) 829 (forward-line 1)
814 (insert (gnus-version) "\n") 830 (insert (gnus-version) "\n"
815 (insert (emacs-version) "\n") 831 (emacs-version) "\n")
816 (when (and (boundp 'nntp-server-type) 832 (when (and (boundp 'nntp-server-type)
817 (stringp nntp-server-type)) 833 (stringp nntp-server-type))
818 (insert nntp-server-type)) 834 (insert nntp-server-type))
@@ -834,12 +850,13 @@ The source file has to be in the Emacs load path."
834 "gnus-art.el" "gnus-start.el" "gnus-async.el" 850 "gnus-art.el" "gnus-start.el" "gnus-async.el"
835 "gnus-msg.el" "gnus-score.el" "gnus-win.el" "gnus-topic.el" 851 "gnus-msg.el" "gnus-score.el" "gnus-win.el" "gnus-topic.el"
836 "nnmail.el" "message.el")) 852 "nnmail.el" "message.el"))
853 (point (point))
837 file expr olist sym) 854 file expr olist sym)
838 (gnus-message 4 "Please wait while we snoop your variables...") 855 (gnus-message 4 "Please wait while we snoop your variables...")
839 (sit-for 0) 856 (sit-for 0)
840 ;; Go through all the files looking for non-default values for variables. 857 ;; Go through all the files looking for non-default values for variables.
841 (save-excursion 858 (save-excursion
842 (set-buffer (get-buffer-create " *gnus bug info*")) 859 (set-buffer (gnus-get-buffer-create " *gnus bug info*"))
843 (buffer-disable-undo (current-buffer)) 860 (buffer-disable-undo (current-buffer))
844 (while files 861 (while files
845 (erase-buffer) 862 (erase-buffer)
@@ -879,11 +896,12 @@ The source file has to be in the Emacs load path."
879 (insert ";; (makeunbound '" (symbol-name (car olist)) ")\n")) 896 (insert ";; (makeunbound '" (symbol-name (car olist)) ")\n"))
880 (setq olist (cdr olist))) 897 (setq olist (cdr olist)))
881 (insert "\n\n") 898 (insert "\n\n")
882 ;; Remove any null chars - they seem to cause trouble for some 899 ;; Remove any control chars - they seem to cause trouble for some
883 ;; mailers. (Byte-compiled output from the stuff above.) 900 ;; mailers. (Byte-compiled output from the stuff above.)
884 (goto-char (point-min)) 901 (goto-char point)
885 (while (re-search-forward "[\000\200]" nil t) 902 (while (re-search-forward "[\000-\010\013-\037\200-\237]" nil t)
886 (replace-match "" t t)))) 903 (replace-match (format "\\%03o" (string-to-char (match-string 0)))
904 t t))))
887 905
888;;; Treatment of rejected articles. 906;;; Treatment of rejected articles.
889;;; Bounced mail. 907;;; Bounced mail.
@@ -978,8 +996,11 @@ this is a reply."
978 "Insert the Gcc to say where the article is to be archived." 996 "Insert the Gcc to say where the article is to be archived."
979 (let* ((var gnus-message-archive-group) 997 (let* ((var gnus-message-archive-group)
980 (group (or group gnus-newsgroup-name "")) 998 (group (or group gnus-newsgroup-name ""))
981 result 999 (gcc-self-val
982 gcc-self-val 1000 (and gnus-newsgroup-name
1001 (gnus-group-find-parameter
1002 gnus-newsgroup-name 'gcc-self)))
1003 result
983 (groups 1004 (groups
984 (cond 1005 (cond
985 ((null gnus-message-archive-method) 1006 ((null gnus-message-archive-method)
@@ -1015,7 +1036,7 @@ this is a reply."
1015 (setq var (cdr var))) 1036 (setq var (cdr var)))
1016 result))) 1037 result)))
1017 name) 1038 name)
1018 (when groups 1039 (when (or groups gcc-self-val)
1019 (when (stringp groups) 1040 (when (stringp groups)
1020 (setq groups (list groups))) 1041 (setq groups (list groups)))
1021 (save-excursion 1042 (save-excursion
@@ -1023,10 +1044,8 @@ this is a reply."
1023 (message-narrow-to-headers) 1044 (message-narrow-to-headers)
1024 (goto-char (point-max)) 1045 (goto-char (point-max))
1025 (insert "Gcc: ") 1046 (insert "Gcc: ")
1026 (if (and gnus-newsgroup-name 1047 (if gcc-self-val
1027 (setq gcc-self-val 1048 ;; Use the `gcc-self' param value instead.
1028 (gnus-group-find-parameter
1029 gnus-newsgroup-name 'gcc-self)))
1030 (progn 1049 (progn
1031 (insert 1050 (insert
1032 (if (stringp gcc-self-val) 1051 (if (stringp gcc-self-val)
@@ -1037,6 +1056,7 @@ this is a reply."
1037 (progn 1056 (progn
1038 (beginning-of-line) 1057 (beginning-of-line)
1039 (kill-line)))) 1058 (kill-line))))
1059 ;; Use the list of groups.
1040 (while (setq name (pop groups)) 1060 (while (setq name (pop groups))
1041 (insert (if (string-match ":" name) 1061 (insert (if (string-match ":" name)
1042 name 1062 name
@@ -1046,31 +1066,88 @@ this is a reply."
1046 (insert " "))) 1066 (insert " ")))
1047 (insert "\n"))))))) 1067 (insert "\n")))))))
1048 1068
1049(defun gnus-summary-send-draft () 1069;;; Posting styles.
1050 "Enter a mail/post buffer to edit and send the draft." 1070
1051 (interactive) 1071(defvar gnus-message-style-insertions nil)
1052 (gnus-set-global-variables) 1072
1053 (let (buf) 1073(defun gnus-configure-posting-styles ()
1054 (if (not (setq buf (gnus-request-restore-buffer 1074 "Configure posting styles according to `gnus-posting-styles'."
1055 (gnus-summary-article-number) gnus-newsgroup-name))) 1075 (unless gnus-inhibit-posting-styles
1056 (error "Couldn't restore the article") 1076 (let ((styles gnus-posting-styles)
1057 (switch-to-buffer buf) 1077 (gnus-newsgroup-name (or gnus-newsgroup-name ""))
1058 (when (eq major-mode 'news-reply-mode) 1078 style match variable attribute value value-value)
1059 (local-set-key "\C-c\C-c" 'gnus-inews-news)) 1079 (make-local-variable 'gnus-message-style-insertions)
1060 ;; Insert the separator. 1080 ;; Go through all styles and look for matches.
1061 (goto-char (point-min)) 1081 (while styles
1062 (search-forward "\n\n") 1082 (setq style (pop styles)
1063 (forward-char -1) 1083 match (pop style))
1064 (insert mail-header-separator) 1084 (when (cond ((stringp match)
1065 ;; Configure windows. 1085 ;; Regexp string match on the group name.
1066 (let ((gnus-draft-buffer (current-buffer))) 1086 (string-match match gnus-newsgroup-name))
1067 (gnus-configure-windows 'draft t) 1087 ((or (symbolp match)
1068 (goto-char (point)))))) 1088 (gnus-functionp match))
1069 1089 (cond ((gnus-functionp match)
1070(gnus-add-shutdown 'gnus-inews-close 'gnus) 1090 ;; Function to be called.
1071 1091 (funcall match))
1072(defun gnus-inews-close () 1092 ((boundp match)
1073 (setq gnus-inews-sent-ids nil)) 1093 ;; Variable to be checked.
1094 (symbol-value match))))
1095 ((listp match)
1096 ;; This is a form to be evaled.
1097 (eval match)))
1098 ;; We have a match, so we set the variables.
1099 (while style
1100 (setq attribute (pop style)
1101 value (cadr attribute)
1102 variable nil)
1103 ;; We find the variable that is to be modified.
1104 (if (and (not (stringp (car attribute)))
1105 (not (eq 'body (car attribute)))
1106 (not (setq variable
1107 (cdr (assq (car attribute)
1108 gnus-posting-style-alist)))))
1109 (message "Couldn't find attribute %s" (car attribute))
1110 ;; We get the value.
1111 (setq value-value
1112 (cond ((stringp value)
1113 value)
1114 ((or (symbolp value)
1115 (gnus-functionp value))
1116 (cond ((gnus-functionp value)
1117 (funcall value))
1118 ((boundp value)
1119 (symbol-value value))))
1120 ((listp value)
1121 (eval value))))
1122 (if variable
1123 ;; This is an ordinary variable.
1124 (set (make-local-variable variable) value-value)
1125 ;; This is either a body or a header to be inserted in the
1126 ;; message.
1127 (when value-value
1128 (let ((attr (car attribute)))
1129 (make-local-variable 'message-setup-hook)
1130 (if (eq 'body attr)
1131 (add-hook 'message-setup-hook
1132 `(lambda ()
1133 (save-excursion
1134 (message-goto-body)
1135 (insert ,value-value))))
1136 (add-hook 'message-setup-hook
1137 'gnus-message-insert-stylings)
1138 (push (cons (if (stringp attr) attr
1139 (symbol-name attr))
1140 value-value)
1141 gnus-message-style-insertions))))))))))))
1142
1143(defun gnus-message-insert-stylings ()
1144 (let (val)
1145 (save-excursion
1146 (message-goto-eoh)
1147 (while (setq val (pop gnus-message-style-insertions))
1148 (when (cdr val)
1149 (insert (car val) ": " (cdr val) "\n"))
1150 (gnus-pull (car val) gnus-message-style-insertions)))))
1074 1151
1075;;; Allow redefinition of functions. 1152;;; Allow redefinition of functions.
1076 1153
diff --git a/lisp/gnus/gnus-mule.el b/lisp/gnus/gnus-mule.el
index 2a149bef3f9..4d22cecc169 100644
--- a/lisp/gnus/gnus-mule.el
+++ b/lisp/gnus/gnus-mule.el
@@ -125,12 +125,15 @@ coding-system for reading and writing respectively."
125;; current news group is encoded. This function is set in 125;; current news group is encoded. This function is set in
126;; `gnus-parse-headers-hook'. 126;; `gnus-parse-headers-hook'.
127(defun gnus-mule-select-coding-system () 127(defun gnus-mule-select-coding-system ()
128 (save-excursion 128 (if (gnus-buffer-live-p gnus-summary-buffer)
129 (set-buffer gnus-summary-buffer) 129 (save-excursion
130 (let ((coding-system (gnus-mule-get-coding-system gnus-newsgroup-name))) 130 (set-buffer gnus-summary-buffer)
131 (setq gnus-mule-coding-system 131 (let ((coding-system
132 (if (and coding-system (coding-system-p (car coding-system))) 132 (gnus-mule-get-coding-system gnus-newsgroup-name)))
133 (car coding-system)))))) 133 (setq gnus-mule-coding-system
134 (if (and coding-system (coding-system-p (car coding-system)))
135 (car coding-system)))))
136 'binary))
134 137
135;; Decode the current article. This function is set in 138;; Decode the current article. This function is set in
136;; `gnus-show-traditional-method'. 139;; `gnus-show-traditional-method'.
@@ -193,7 +196,7 @@ coding-system for reading and writing respectively."
193 nnmail-file-coding-system 'binary) 196 nnmail-file-coding-system 'binary)
194 ) 197 )
195 198
196(gnus-mule-add-group "" '(undecided . iso-latin-1)) 199(gnus-mule-add-group "" 'iso-latin-1)
197(gnus-mule-add-group "fj" 'iso-2022-7bit) 200(gnus-mule-add-group "fj" 'iso-2022-7bit)
198(gnus-mule-add-group "tnn" 'iso-2022-7bit) 201(gnus-mule-add-group "tnn" 'iso-2022-7bit)
199(gnus-mule-add-group "japan" 'iso-2022-7bit) 202(gnus-mule-add-group "japan" 'iso-2022-7bit)
diff --git a/lisp/gnus/gnus-nocem.el b/lisp/gnus/gnus-nocem.el
index 637743a50a7..1020c729880 100644
--- a/lisp/gnus/gnus-nocem.el
+++ b/lisp/gnus/gnus-nocem.el
@@ -1,7 +1,7 @@
1;;; gnus-nocem.el --- NoCeM pseudo-cancellation treatment 1;;; gnus-nocem.el --- NoCeM pseudo-cancellation treatment
2;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. 2;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: news 5;; Keywords: news
6 6
7;; This file is part of GNU Emacs. 7;; This file is part of GNU Emacs.
@@ -27,6 +27,8 @@
27 27
28(eval-when-compile (require 'cl)) 28(eval-when-compile (require 'cl))
29 29
30(eval-when-compile (require 'cl))
31
30(require 'gnus) 32(require 'gnus)
31(require 'nnmail) 33(require 'nnmail)
32(require 'gnus-art) 34(require 'gnus-art)
@@ -40,7 +42,7 @@
40(defcustom gnus-nocem-groups 42(defcustom gnus-nocem-groups
41 '("news.lists.filters" "news.admin.net-abuse.bulletins" 43 '("news.lists.filters" "news.admin.net-abuse.bulletins"
42 "alt.nocem.misc" "news.admin.net-abuse.announce") 44 "alt.nocem.misc" "news.admin.net-abuse.announce")
43 "List of groups that will be searched for NoCeM messages." 45 "*List of groups that will be searched for NoCeM messages."
44 :group 'gnus-nocem 46 :group 'gnus-nocem
45 :type '(repeat (string :tag "Group"))) 47 :type '(repeat (string :tag "Group")))
46 48
@@ -52,9 +54,11 @@
52 "snowhare@xmission.com" ; Benjamin "Snowhare" Franz 54 "snowhare@xmission.com" ; Benjamin "Snowhare" Franz
53 "red@redpoll.mrfs.oh.us (Richard E. Depew)" ; ARMM! ARMM! 55 "red@redpoll.mrfs.oh.us (Richard E. Depew)" ; ARMM! ARMM!
54 ) 56 )
55 "List of NoCeM issuers to pay attention to." 57 "*List of NoCeM issuers to pay attention to.
58
59This can also be a list of `(ISSUER CONDITIONS)' elements."
56 :group 'gnus-nocem 60 :group 'gnus-nocem
57 :type '(repeat string)) 61 :type '(repeat (choice string sexp)))
58 62
59(defcustom gnus-nocem-directory 63(defcustom gnus-nocem-directory
60 (nnheader-concat gnus-article-save-directory "NoCeM/") 64 (nnheader-concat gnus-article-save-directory "NoCeM/")
@@ -106,8 +110,7 @@ matches an previously scanned and verified nocem message."
106 "Real-name mappings of subscribed groups.") 110 "Real-name mappings of subscribed groups.")
107 111
108(defun gnus-fill-real-hashtb () 112(defun gnus-fill-real-hashtb ()
109 "Fill up a hash table with the real-name mappings from the user's 113 "Fill up a hash table with the real-name mappings from the user's active file."
110active file."
111 (setq gnus-nocem-real-group-hashtb (gnus-make-hashtable 114 (setq gnus-nocem-real-group-hashtb (gnus-make-hashtable
112 (length gnus-newsrc-alist))) 115 (length gnus-newsrc-alist)))
113 (mapcar (lambda (group) 116 (mapcar (lambda (group)
@@ -187,7 +190,7 @@ active file."
187 (gnus-message 7 "Checking article %d in %s for NoCeM..." 190 (gnus-message 7 "Checking article %d in %s for NoCeM..."
188 (mail-header-number header) group) 191 (mail-header-number header) group)
189 (let ((date (mail-header-date header)) 192 (let ((date (mail-header-date header))
190 issuer b e) 193 issuer b e type)
191 (when (or (not date) 194 (when (or (not date)
192 (nnmail-time-less 195 (nnmail-time-less
193 (nnmail-time-since (nnmail-date-to-time date)) 196 (nnmail-time-since (nnmail-date-to-time date))
@@ -204,15 +207,36 @@ active file."
204 (setq e (search-forward "\n@@BEGIN NCM BODY\n" nil t))) 207 (setq e (search-forward "\n@@BEGIN NCM BODY\n" nil t)))
205 ;; We get the name of the issuer. 208 ;; We get the name of the issuer.
206 (narrow-to-region b e) 209 (narrow-to-region b e)
207 (setq issuer (mail-fetch-field "issuer")) 210 (setq issuer (mail-fetch-field "issuer")
211 type (mail-fetch-field "issuer"))
208 (widen) 212 (widen)
209 (or (member issuer gnus-nocem-issuers) 213 (if (not (gnus-nocem-message-wanted-p issuer type))
210 (message "invalid NoCeM issuer: %s" issuer)) 214 (message "invalid NoCeM issuer: %s" issuer)
211 (and (member issuer gnus-nocem-issuers) ; We like her.... 215 (and (gnus-nocem-verify-issuer issuer) ; She is who she says she is.
212 (gnus-nocem-verify-issuer issuer) ; She is who she says she is... 216 (gnus-nocem-enter-article) ; We gobble the message.
213 (gnus-nocem-enter-article) ; We gobble the message.. 217 (push (mail-header-message-id header) ; But don't come back for
214 (push (mail-header-message-id header) ; But don't come back for 218 gnus-nocem-seen-message-ids))))))) ; second helpings.
215 gnus-nocem-seen-message-ids)))))) ; second helpings. 219
220(defun gnus-nocem-message-wanted-p (issuer type)
221 (let ((issuers gnus-nocem-issuers)
222 wanted conditions condition)
223 (cond
224 ;; Do the quick check first.
225 ((member issuer issuers)
226 t)
227 ((setq conditions (cdr (assoc issuer issuers)))
228 ;; Check whether we want this type.
229 (while (setq condition (pop conditions))
230 (cond
231 ((stringp condition)
232 (setq wanted (string-match condition type)))
233 ((and (consp condition)
234 (eq (car condition) 'not)
235 (stringp (cadr condition)))
236 (setq wanted (not (string-match (cadr condition) type))))
237 (t
238 (error "Invalid NoCeM condition: %S" condition))))
239 wanted))))
216 240
217(defun gnus-nocem-verify-issuer (person) 241(defun gnus-nocem-verify-issuer (person)
218 "Verify using PGP that the canceler is who she says she is." 242 "Verify using PGP that the canceler is who she says she is."
@@ -322,7 +346,8 @@ active file."
322 346
323(defun gnus-nocem-unwanted-article-p (id) 347(defun gnus-nocem-unwanted-article-p (id)
324 "Say whether article ID in the current group is wanted." 348 "Say whether article ID in the current group is wanted."
325 (gnus-gethash id gnus-nocem-hashtb)) 349 (and gnus-nocem-hashtb
350 (gnus-gethash id gnus-nocem-hashtb)))
326 351
327(provide 'gnus-nocem) 352(provide 'gnus-nocem)
328 353
diff --git a/lisp/gnus/gnus-range.el b/lisp/gnus/gnus-range.el
index 6b86f4df3ca..71684707de3 100644
--- a/lisp/gnus/gnus-range.el
+++ b/lisp/gnus/gnus-range.el
@@ -1,7 +1,7 @@
1;;; gnus-range.el --- range and sequence functions for Gnus 1;;; gnus-range.el --- range and sequence functions for Gnus
2;; Copyright (C) 1996,97 Free Software Foundation, Inc. 2;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: news 5;; Keywords: news
6 6
7;; This file is part of GNU Emacs. 7;; This file is part of GNU Emacs.
@@ -27,6 +27,8 @@
27 27
28(eval-when-compile (require 'cl)) 28(eval-when-compile (require 'cl))
29 29
30(eval-when-compile (require 'cl))
31
30;;; List and range functions 32;;; List and range functions
31 33
32(defun gnus-last-element (list) 34(defun gnus-last-element (list)
@@ -55,7 +57,7 @@
55 list1)) 57 list1))
56 58
57(defun gnus-sorted-complement (list1 list2) 59(defun gnus-sorted-complement (list1 list2)
58 "Return a list of elements of LIST1 that do not appear in LIST2. 60 "Return a list of elements that are in LIST1 or LIST2 but not both.
59Both lists have to be sorted over <." 61Both lists have to be sorted over <."
60 (let (out) 62 (let (out)
61 (if (or (null list1) (null list2)) 63 (if (or (null list1) (null list2))
diff --git a/lisp/gnus/gnus-salt.el b/lisp/gnus/gnus-salt.el
index 1f680e29416..73d949fc22f 100644
--- a/lisp/gnus/gnus-salt.el
+++ b/lisp/gnus/gnus-salt.el
@@ -1,7 +1,8 @@
1;;; gnus-salt.el --- alternate summary mode interfaces for Gnus 1;;; gnus-salt.el --- alternate summary mode interfaces for Gnus
2;; Copyright (C) 1996,97 Free Software Foundation, Inc. 2;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: news
5 6
6;; This file is part of GNU Emacs. 7;; This file is part of GNU Emacs.
7 8
@@ -26,6 +27,8 @@
26 27
27(eval-when-compile (require 'cl)) 28(eval-when-compile (require 'cl))
28 29
30(eval-when-compile (require 'cl))
31
29(require 'gnus) 32(require 'gnus)
30(require 'gnus-sum) 33(require 'gnus-sum)
31 34
@@ -70,25 +73,13 @@ It accepts the same format specs that `gnus-summary-line-format' does."
70(unless gnus-pick-mode-map 73(unless gnus-pick-mode-map
71 (setq gnus-pick-mode-map (make-sparse-keymap)) 74 (setq gnus-pick-mode-map (make-sparse-keymap))
72 75
73 (gnus-define-keys 76 (gnus-define-keys gnus-pick-mode-map
74 gnus-pick-mode-map 77 " " gnus-pick-next-page
75 "t" gnus-uu-mark-thread 78 "u" gnus-pick-unmark-article-or-thread
76 "T" gnus-uu-unmark-thread 79 "." gnus-pick-article-or-thread
77 " " gnus-pick-next-page 80 gnus-down-mouse-2 gnus-pick-mouse-pick-region
78 "u" gnus-summary-unmark-as-processable 81 "\r" gnus-pick-start-reading
79 "U" gnus-summary-unmark-all-processable 82 ))
80 "v" gnus-uu-mark-over
81 "r" gnus-uu-mark-region
82 "R" gnus-uu-unmark-region
83 "e" gnus-uu-mark-by-regexp
84 "E" gnus-uu-mark-by-regexp
85 "b" gnus-uu-mark-buffer
86 "B" gnus-uu-unmark-buffer
87 "." gnus-pick-article
88 gnus-down-mouse-2 gnus-pick-mouse-pick-region
89 ;;gnus-mouse-2 gnus-pick-mouse-pick
90 "X" gnus-pick-start-reading
91 "\r" gnus-pick-start-reading))
92 83
93(defun gnus-pick-make-menu-bar () 84(defun gnus-pick-make-menu-bar ()
94 (unless (boundp 'gnus-pick-menu) 85 (unless (boundp 'gnus-pick-menu)
@@ -99,14 +90,14 @@ It accepts the same format specs that `gnus-summary-line-format' does."
99 ["Article" gnus-summary-mark-as-processable t] 90 ["Article" gnus-summary-mark-as-processable t]
100 ["Thread" gnus-uu-mark-thread t] 91 ["Thread" gnus-uu-mark-thread t]
101 ["Region" gnus-uu-mark-region t] 92 ["Region" gnus-uu-mark-region t]
102 ["Regexp" gnus-uu-mark-regexp t] 93 ["Regexp" gnus-uu-mark-by-regexp t]
103 ["Buffer" gnus-uu-mark-buffer t]) 94 ["Buffer" gnus-uu-mark-buffer t])
104 ("Unpick" 95 ("Unpick"
105 ["Article" gnus-summary-unmark-as-processable t] 96 ["Article" gnus-summary-unmark-as-processable t]
106 ["Thread" gnus-uu-unmark-thread t] 97 ["Thread" gnus-uu-unmark-thread t]
107 ["Region" gnus-uu-unmark-region t] 98 ["Region" gnus-uu-unmark-region t]
108 ["Regexp" gnus-uu-unmark-regexp t] 99 ["Regexp" gnus-uu-unmark-by-regexp t]
109 ["Buffer" gnus-uu-unmark-buffer t]) 100 ["Buffer" gnus-summary-unmark-all-processable t])
110 ["Start reading" gnus-pick-start-reading t] 101 ["Start reading" gnus-pick-start-reading t]
111 ["Switch pick mode off" gnus-pick-mode gnus-pick-mode])))) 102 ["Switch pick mode off" gnus-pick-mode gnus-pick-mode]))))
112 103
@@ -133,7 +124,7 @@ It accepts the same format specs that `gnus-summary-line-format' does."
133 (when (gnus-visual-p 'pick-menu 'menu) 124 (when (gnus-visual-p 'pick-menu 'menu)
134 (gnus-pick-make-menu-bar)) 125 (gnus-pick-make-menu-bar))
135 (gnus-add-minor-mode 'gnus-pick-mode " Pick" gnus-pick-mode-map) 126 (gnus-add-minor-mode 'gnus-pick-mode " Pick" gnus-pick-mode-map)
136 (run-hooks 'gnus-pick-mode-hook)))) 127 (gnus-run-hooks 'gnus-pick-mode-hook))))
137 128
138(defun gnus-pick-setup-message () 129(defun gnus-pick-setup-message ()
139 "Make Message do the right thing on exit." 130 "Make Message do the right thing on exit."
@@ -172,21 +163,48 @@ If given a prefix, mark all unpicked articles as read."
172 (gnus-summary-next-group))) 163 (gnus-summary-next-group)))
173 (error "No articles have been picked")))) 164 (error "No articles have been picked"))))
174 165
166(defun gnus-pick-goto-article (arg)
167 "Go to the article number indicated by ARG. If ARG is an invalid
168article number, then stay on current line."
169 (let (pos)
170 (save-excursion
171 (goto-char (point-min))
172 (when (zerop (forward-line (1- (prefix-numeric-value arg))))
173 (setq pos (point))))
174 (if (not pos)
175 (gnus-error 2 "No such line: %s" arg)
176 (goto-char pos))))
177
175(defun gnus-pick-article (&optional arg) 178(defun gnus-pick-article (&optional arg)
176 "Pick the article on the current line. 179 "Pick the article on the current line.
177If ARG, pick the article on that line instead." 180If ARG, pick the article on that line instead."
178 (interactive "P") 181 (interactive "P")
179 (when arg 182 (when arg
180 (let (pos) 183 (gnus-pick-goto-article arg))
181 (save-excursion
182 (goto-char (point-min))
183 (when (zerop (forward-line (1- (prefix-numeric-value arg))))
184 (setq pos (point))))
185 (if (not pos)
186 (gnus-error 2 "No such line: %s" arg)
187 (goto-char pos))))
188 (gnus-summary-mark-as-processable 1)) 184 (gnus-summary-mark-as-processable 1))
189 185
186(defun gnus-pick-article-or-thread (&optional arg)
187 "If gnus-thread-hide-subtree is t, then pick the thread on the current line.
188Otherwise pick the article on the current line.
189If ARG, pick the article/thread on that line instead."
190 (interactive "P")
191 (when arg
192 (gnus-pick-goto-article arg))
193 (if gnus-thread-hide-subtree
194 (gnus-uu-mark-thread)
195 (gnus-summary-mark-as-processable 1)))
196
197(defun gnus-pick-unmark-article-or-thread (&optional arg)
198 "If gnus-thread-hide-subtree is t, then unmark the thread on current line.
199Otherwise unmark the article on current line.
200If ARG, unmark thread/article on that line instead."
201 (interactive "P")
202 (when arg
203 (gnus-pick-goto-article arg))
204 (if gnus-thread-hide-subtree
205 (gnus-uu-unmark-thread)
206 (gnus-summary-unmark-as-processable 1)))
207
190(defun gnus-pick-mouse-pick (e) 208(defun gnus-pick-mouse-pick (e)
191 (interactive "e") 209 (interactive "e")
192 (mouse-set-point e) 210 (mouse-set-point e)
@@ -203,8 +221,7 @@ This must be bound to a button-down mouse event."
203 (start-point (posn-point start-posn)) 221 (start-point (posn-point start-posn))
204 (start-line (1+ (count-lines 1 start-point))) 222 (start-line (1+ (count-lines 1 start-point)))
205 (start-window (posn-window start-posn)) 223 (start-window (posn-window start-posn))
206 (start-frame (window-frame start-window)) 224 (bounds (gnus-window-edges start-window))
207 (bounds (window-edges start-window))
208 (top (nth 1 bounds)) 225 (top (nth 1 bounds))
209 (bottom (if (window-minibuffer-p start-window) 226 (bottom (if (window-minibuffer-p start-window)
210 (nth 3 bounds) 227 (nth 3 bounds)
@@ -223,50 +240,48 @@ This must be bound to a button-down mouse event."
223 ;; end-of-range is used only in the single-click case. 240 ;; end-of-range is used only in the single-click case.
224 ;; It is the place where the drag has reached so far 241 ;; It is the place where the drag has reached so far
225 ;; (but not outside the window where the drag started). 242 ;; (but not outside the window where the drag started).
226 (let (event end end-point last-end-point (end-of-range (point))) 243 (let (event end end-point (end-of-range (point)))
227 (track-mouse 244 (track-mouse
228 (while (progn 245 (while (progn
229 (setq event (read-event)) 246 (setq event (cdr (gnus-read-event-char)))
230 (or (mouse-movement-p event) 247 (or (mouse-movement-p event)
231 (eq (car-safe event) 'switch-frame))) 248 (eq (car-safe event) 'switch-frame)))
232 (if (eq (car-safe event) 'switch-frame) 249 (if (eq (car-safe event) 'switch-frame)
233 nil 250 nil
234 (setq end (event-end event) 251 (setq end (event-end event)
235 end-point (posn-point end)) 252 end-point (posn-point end))
236 (when end-point 253
237 (setq last-end-point end-point)) 254 (cond
238 255 ;; Are we moving within the original window?
239 (cond 256 ((and (eq (posn-window end) start-window)
240 ;; Are we moving within the original window? 257 (integer-or-marker-p end-point))
241 ((and (eq (posn-window end) start-window) 258 ;; Go to START-POINT first, so that when we move to END-POINT,
242 (integer-or-marker-p end-point)) 259 ;; if it's in the middle of intangible text,
243 ;; Go to START-POINT first, so that when we move to END-POINT, 260 ;; point jumps in the direction away from START-POINT.
244 ;; if it's in the middle of intangible text, 261 (goto-char start-point)
245 ;; point jumps in the direction away from START-POINT. 262 (goto-char end-point)
246 (goto-char start-point) 263 (gnus-pick-article)
247 (goto-char end-point) 264 ;; In case the user moved his mouse really fast, pick
248 (gnus-pick-article) 265 ;; articles on the line between this one and the last one.
249 ;; In case the user moved his mouse really fast, pick 266 (let* ((this-line (1+ (count-lines 1 end-point)))
250 ;; articles on the line between this one and the last one. 267 (min-line (min this-line start-line))
251 (let* ((this-line (1+ (count-lines 1 end-point))) 268 (max-line (max this-line start-line)))
252 (min-line (min this-line start-line)) 269 (while (< min-line max-line)
253 (max-line (max this-line start-line))) 270 (goto-line min-line)
254 (while (< min-line max-line) 271 (gnus-pick-article)
255 (goto-line min-line) 272 (setq min-line (1+ min-line)))
256 (gnus-pick-article) 273 (setq start-line this-line))
257 (setq min-line (1+ min-line))) 274 (when (zerop (% click-count 3))
258 (setq start-line this-line)) 275 (setq end-of-range (point))))
259 (when (zerop (% click-count 3)) 276 (t
260 (setq end-of-range (point)))) 277 (let ((mouse-row (cdr (cdr (mouse-position)))))
261 (t 278 (cond
262 (let ((mouse-row (cdr (cdr (mouse-position))))) 279 ((null mouse-row))
263 (cond 280 ((< mouse-row top)
264 ((null mouse-row)) 281 (mouse-scroll-subr start-window (- mouse-row top)))
265 ((< mouse-row top) 282 ((>= mouse-row bottom)
266 (mouse-scroll-subr start-window (- mouse-row top))) 283 (mouse-scroll-subr start-window
267 ((>= mouse-row bottom) 284 (1+ (- mouse-row bottom)))))))))))
268 (mouse-scroll-subr start-window
269 (1+ (- mouse-row bottom)))))))))))
270 (when (consp event) 285 (when (consp event)
271 (let ((fun (key-binding (vector (car event))))) 286 (let ((fun (key-binding (vector (car event)))))
272 ;; Run the binding of the terminating up-event, if possible. 287 ;; Run the binding of the terminating up-event, if possible.
@@ -336,7 +351,7 @@ This must be bound to a button-down mouse event."
336 (when (gnus-visual-p 'binary-menu 'menu) 351 (when (gnus-visual-p 'binary-menu 'menu)
337 (gnus-binary-make-menu-bar)) 352 (gnus-binary-make-menu-bar))
338 (gnus-add-minor-mode 'gnus-binary-mode " Binary" gnus-binary-mode-map) 353 (gnus-add-minor-mode 'gnus-binary-mode " Binary" gnus-binary-mode-map)
339 (run-hooks 'gnus-binary-mode-hook)))) 354 (gnus-run-hooks 'gnus-binary-mode-hook))))
340 355
341(defun gnus-binary-display-article (article &optional all-header) 356(defun gnus-binary-display-article (article &optional all-header)
342 "Run ARTICLE through the binary decode functions." 357 "Run ARTICLE through the binary decode functions."
@@ -363,7 +378,8 @@ This must be bound to a button-down mouse event."
363 "If non-nil, minimize the tree buffer window. 378 "If non-nil, minimize the tree buffer window.
364If a number, never let the tree buffer grow taller than that number of 379If a number, never let the tree buffer grow taller than that number of
365lines." 380lines."
366 :type 'boolean 381 :type '(choice boolean
382 integer)
367 :group 'gnus-summary-tree) 383 :group 'gnus-summary-tree)
368 384
369(defcustom gnus-selected-tree-face 'modeline 385(defcustom gnus-selected-tree-face 'modeline
@@ -445,12 +461,8 @@ Two predefined functions are available:
445(defun gnus-tree-mode () 461(defun gnus-tree-mode ()
446 "Major mode for displaying thread trees." 462 "Major mode for displaying thread trees."
447 (interactive) 463 (interactive)
448 (setq gnus-tree-mode-line-format-spec 464 (gnus-set-format 'tree-mode)
449 (gnus-parse-format gnus-tree-mode-line-format 465 (gnus-set-format 'tree t)
450 gnus-summary-mode-line-format-alist))
451 (setq gnus-tree-line-format-spec
452 (gnus-parse-format gnus-tree-line-format
453 gnus-tree-line-format-alist t))
454 (when (gnus-visual-p 'tree-menu 'menu) 466 (when (gnus-visual-p 'tree-menu 'menu)
455 (gnus-tree-make-menu-bar)) 467 (gnus-tree-make-menu-bar))
456 (kill-all-local-variables) 468 (kill-all-local-variables)
@@ -465,13 +477,14 @@ Two predefined functions are available:
465 (gnus-set-work-buffer) 477 (gnus-set-work-buffer)
466 (gnus-tree-node-insert (make-mail-header "") nil) 478 (gnus-tree-node-insert (make-mail-header "") nil)
467 (setq gnus-tree-node-length (1- (point)))) 479 (setq gnus-tree-node-length (1- (point))))
468 (run-hooks 'gnus-tree-mode-hook)) 480 (gnus-run-hooks 'gnus-tree-mode-hook))
469 481
470(defun gnus-tree-read-summary-keys (&optional arg) 482(defun gnus-tree-read-summary-keys (&optional arg)
471 "Read a summary buffer key sequence and execute it." 483 "Read a summary buffer key sequence and execute it."
472 (interactive "P") 484 (interactive "P")
473 (let ((buf (current-buffer)) 485 (let ((buf (current-buffer))
474 win) 486 win)
487 (set-buffer gnus-article-buffer)
475 (gnus-article-read-summary-keys arg nil t) 488 (gnus-article-read-summary-keys arg nil t)
476 (when (setq win (get-buffer-window buf)) 489 (when (setq win (get-buffer-window buf))
477 (select-window win) 490 (select-window win)
@@ -543,9 +556,8 @@ Two predefined functions are available:
543(defun gnus-get-tree-buffer () 556(defun gnus-get-tree-buffer ()
544 "Return the tree buffer properly initialized." 557 "Return the tree buffer properly initialized."
545 (save-excursion 558 (save-excursion
546 (set-buffer (get-buffer-create gnus-tree-buffer)) 559 (set-buffer (gnus-get-buffer-create gnus-tree-buffer))
547 (unless (eq major-mode 'gnus-tree-mode) 560 (unless (eq major-mode 'gnus-tree-mode)
548 (gnus-add-current-to-buffer-list)
549 (gnus-tree-mode)) 561 (gnus-tree-mode))
550 (current-buffer))) 562 (current-buffer)))
551 563
@@ -640,7 +652,7 @@ Two predefined functions are available:
640 (not (eval (caar list)))) 652 (not (eval (caar list))))
641 (setq list (cdr list))))) 653 (setq list (cdr list)))))
642 (unless (eq (setq face (cdar list)) (get-text-property beg 'face)) 654 (unless (eq (setq face (cdar list)) (get-text-property beg 'face))
643 (gnus-put-text-property 655 (gnus-put-text-property-excluding-characters-with-faces
644 beg end 'face 656 beg end 'face
645 (if (boundp face) (symbol-value face) face))))) 657 (if (boundp face) (symbol-value face) face)))))
646 658
@@ -749,7 +761,8 @@ Two predefined functions are available:
749 (setq beg (point)) 761 (setq beg (point))
750 (forward-char -1) 762 (forward-char -1)
751 ;; Draw "-" lines leftwards. 763 ;; Draw "-" lines leftwards.
752 (while (= (char-after (1- (point))) ? ) 764 (while (and (> (point) 1)
765 (= (char-after (1- (point))) ? ))
753 (delete-char -1) 766 (delete-char -1)
754 (insert (car gnus-tree-parent-child-edges)) 767 (insert (car gnus-tree-parent-child-edges))
755 (forward-char -1)) 768 (forward-char -1))
@@ -800,8 +813,7 @@ Two predefined functions are available:
800 (gnus-get-tree-buffer)) 813 (gnus-get-tree-buffer))
801 814
802(defun gnus-tree-close (group) 815(defun gnus-tree-close (group)
803 ;(gnus-kill-buffer gnus-tree-buffer) 816 (gnus-kill-buffer gnus-tree-buffer))
804 )
805 817
806(defun gnus-highlight-selected-tree (article) 818(defun gnus-highlight-selected-tree (article)
807 "Highlight the selected article in the tree." 819 "Highlight the selected article in the tree."
@@ -960,18 +972,17 @@ The following commands are available:
960 (buffer-disable-undo (current-buffer)) 972 (buffer-disable-undo (current-buffer))
961 (setq buffer-read-only t) 973 (setq buffer-read-only t)
962 (make-local-variable 'gnus-carpal-attached-buffer) 974 (make-local-variable 'gnus-carpal-attached-buffer)
963 (run-hooks 'gnus-carpal-mode-hook)) 975 (gnus-run-hooks 'gnus-carpal-mode-hook))
964 976
965(defun gnus-carpal-setup-buffer (type) 977(defun gnus-carpal-setup-buffer (type)
966 (let ((buffer (symbol-value (intern (format "gnus-carpal-%s-buffer" type))))) 978 (let ((buffer (symbol-value (intern (format "gnus-carpal-%s-buffer" type)))))
967 (if (get-buffer buffer) 979 (if (get-buffer buffer)
968 () 980 ()
969 (save-excursion 981 (save-excursion
970 (set-buffer (get-buffer-create buffer)) 982 (set-buffer (gnus-get-buffer-create buffer))
971 (gnus-carpal-mode) 983 (gnus-carpal-mode)
972 (setq gnus-carpal-attached-buffer 984 (setq gnus-carpal-attached-buffer
973 (intern (format "gnus-%s-buffer" type))) 985 (intern (format "gnus-%s-buffer" type)))
974 (gnus-add-current-to-buffer-list)
975 (let ((buttons (symbol-value 986 (let ((buttons (symbol-value
976 (intern (format "gnus-carpal-%s-buffer-buttons" 987 (intern (format "gnus-carpal-%s-buffer-buttons"
977 type)))) 988 type))))
diff --git a/lisp/gnus/gnus-score.el b/lisp/gnus/gnus-score.el
index 19c9c3ae51e..31b3017d833 100644
--- a/lisp/gnus/gnus-score.el
+++ b/lisp/gnus/gnus-score.el
@@ -2,7 +2,7 @@
2;; Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc. 2;; Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc.
3 3
4;; Author: Per Abrahamsen <amanda@iesd.auc.dk> 4;; Author: Per Abrahamsen <amanda@iesd.auc.dk>
5;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 5;; Lars Magne Ingebrigtsen <larsi@gnus.org>
6;; Keywords: news 6;; Keywords: news
7 7
8;; This file is part of GNU Emacs. 8;; This file is part of GNU Emacs.
@@ -28,10 +28,13 @@
28 28
29(eval-when-compile (require 'cl)) 29(eval-when-compile (require 'cl))
30 30
31(eval-when-compile (require 'cl))
32
31(require 'gnus) 33(require 'gnus)
32(require 'gnus-sum) 34(require 'gnus-sum)
33(require 'gnus-range) 35(require 'gnus-range)
34(require 'message) 36(require 'message)
37(require 'score-mode)
35 38
36(defcustom gnus-global-score-files nil 39(defcustom gnus-global-score-files nil
37 "List of global score files and directories. 40 "List of global score files and directories.
@@ -107,7 +110,11 @@ See the documentation to these functions for more information.
107 110
108This variable can also be a list of functions to be called. Each 111This variable can also be a list of functions to be called. Each
109function should either return a list of score files, or a list of 112function should either return a list of score files, or a list of
110score alists." 113score alists.
114
115If functions other than these pre-defined functions are used,
116the `a' symbolic prefix to the score commands will always use
117\"all.SCORE\"."
111 :group 'gnus-score-files 118 :group 'gnus-score-files
112 :type '(radio (function-item gnus-score-find-single) 119 :type '(radio (function-item gnus-score-find-single)
113 (function-item gnus-score-find-hierarchical) 120 (function-item gnus-score-find-hierarchical)
@@ -117,7 +124,8 @@ score alists."
117(defcustom gnus-score-interactive-default-score 1000 124(defcustom gnus-score-interactive-default-score 1000
118 "*Scoring commands will raise/lower the score with this number as the default." 125 "*Scoring commands will raise/lower the score with this number as the default."
119 :group 'gnus-score-default 126 :group 'gnus-score-default
120 :type 'integer) 127 :type '(choice (const nil)
128 integer))
121 129
122(defcustom gnus-score-expiry-days 7 130(defcustom gnus-score-expiry-days 7
123 "*Number of days before unused score file entries are expired. 131 "*Number of days before unused score file entries are expired.
@@ -195,8 +203,8 @@ It can be:
195 :type '(choice string 203 :type '(choice string
196 (repeat (choice string 204 (repeat (choice string
197 (cons regexp (repeat file)) 205 (cons regexp (repeat file))
198 function)) 206 (function :value fun)))
199 function)) 207 (function :value fun)))
200 208
201(defcustom gnus-home-adapt-file nil 209(defcustom gnus-home-adapt-file nil
202 "Variable to control where new adaptive score entries are to go. 210 "Variable to control where new adaptive score entries are to go.
@@ -206,8 +214,8 @@ This variable allows the same syntax as `gnus-home-score-file'."
206 :type '(choice string 214 :type '(choice string
207 (repeat (choice string 215 (repeat (choice string
208 (cons regexp (repeat file)) 216 (cons regexp (repeat file))
209 function)) 217 (function :value fun)))
210 function)) 218 (function :value fun)))
211 219
212(defcustom gnus-default-adaptive-score-alist 220(defcustom gnus-default-adaptive-score-alist
213 '((gnus-kill-file-mark) 221 '((gnus-kill-file-mark)
@@ -216,7 +224,7 @@ This variable allows the same syntax as `gnus-home-score-file'."
216 (gnus-catchup-mark (subject -10)) 224 (gnus-catchup-mark (subject -10))
217 (gnus-killed-mark (from -1) (subject -20)) 225 (gnus-killed-mark (from -1) (subject -20))
218 (gnus-del-mark (from -2) (subject -15))) 226 (gnus-del-mark (from -2) (subject -15)))
219"Alist of marks and scores." 227"*Alist of marks and scores."
220:group 'gnus-score-adapt 228:group 'gnus-score-adapt
221:type '(repeat (cons (symbol :tag "Mark") 229:type '(repeat (cons (symbol :tag "Mark")
222 (repeat (list (choice :tag "Header" 230 (repeat (list (choice :tag "Header"
@@ -245,7 +253,7 @@ This variable allows the same syntax as `gnus-home-score-file'."
245 "being" "current" "back" "still" "go" "point" "value" "each" "did" 253 "being" "current" "back" "still" "go" "point" "value" "each" "did"
246 "both" "true" "off" "say" "another" "state" "might" "under" "start" 254 "both" "true" "off" "say" "another" "state" "might" "under" "start"
247 "try" "re") 255 "try" "re")
248 "Default list of words to be ignored when doing adaptive word scoring." 256 "*Default list of words to be ignored when doing adaptive word scoring."
249 :group 'gnus-score-adapt 257 :group 'gnus-score-adapt
250 :type '(repeat string)) 258 :type '(repeat string))
251 259
@@ -254,11 +262,21 @@ This variable allows the same syntax as `gnus-home-score-file'."
254 (,gnus-catchup-mark . -10) 262 (,gnus-catchup-mark . -10)
255 (,gnus-killed-mark . -20) 263 (,gnus-killed-mark . -20)
256 (,gnus-del-mark . -15)) 264 (,gnus-del-mark . -15))
257"Alist of marks and scores." 265"*Alist of marks and scores."
258:group 'gnus-score-adapt 266:group 'gnus-score-adapt
259:type '(repeat (cons (character :tag "Mark") 267:type '(repeat (cons (character :tag "Mark")
260 (integer :tag "Score")))) 268 (integer :tag "Score"))))
261 269
270(defcustom gnus-adaptive-word-minimum nil
271 "If a number, this is the minimum score value that can be assigned to a word."
272 :group 'gnus-score-adapt
273 :type '(choice (const nil) integer))
274
275(defcustom gnus-adaptive-word-no-group-words nil
276 "If t, don't adaptively score words included in the group name."
277 :group 'gnus-score-adapt
278 :type 'boolean)
279
262(defcustom gnus-score-mimic-keymap nil 280(defcustom gnus-score-mimic-keymap nil
263 "*Have the score entry functions pretend that they are a keymap." 281 "*Have the score entry functions pretend that they are a keymap."
264 :group 'gnus-score-default 282 :group 'gnus-score-default
@@ -321,7 +339,7 @@ Should be one of the following symbols.
321 f: fuzzy string 339 f: fuzzy string
322 r: regexp string 340 r: regexp string
323 b: before date 341 b: before date
324 a: at date 342 a: after date
325 n: this date 343 n: this date
326 <: less than number 344 <: less than number
327 >: greater than number 345 >: greater than number
@@ -334,7 +352,7 @@ If nil, the user will be asked for a match type."
334 (const :tag "fuzzy string" f) 352 (const :tag "fuzzy string" f)
335 (const :tag "regexp string" r) 353 (const :tag "regexp string" r)
336 (const :tag "before date" b) 354 (const :tag "before date" b)
337 (const :tag "at date" a) 355 (const :tag "after date" a)
338 (const :tag "this date" n) 356 (const :tag "this date" n)
339 (const :tag "less than number" <) 357 (const :tag "less than number" <)
340 (const :tag "greater than number" >) 358 (const :tag "greater than number" >)
@@ -367,6 +385,11 @@ If nil, the user will be asked for a duration."
367 :group 'gnus-score-files 385 :group 'gnus-score-files
368 :type 'function) 386 :type 'function)
369 387
388(defcustom gnus-score-thread-simplify nil
389 "If non-nil, subjects will simplified as in threading."
390 :group 'gnus-score-various
391 :type 'boolean)
392
370 393
371 394
372;; Internal variables. 395;; Internal variables.
@@ -434,7 +457,6 @@ of the last successful match.")
434 457
435(gnus-define-keys (gnus-summary-score-map "V" gnus-summary-mode-map) 458(gnus-define-keys (gnus-summary-score-map "V" gnus-summary-mode-map)
436 "s" gnus-summary-set-score 459 "s" gnus-summary-set-score
437 "a" gnus-summary-score-entry
438 "S" gnus-summary-current-score 460 "S" gnus-summary-current-score
439 "c" gnus-score-change-score-file 461 "c" gnus-score-change-score-file
440 "C" gnus-score-customize 462 "C" gnus-score-customize
@@ -452,13 +474,13 @@ of the last successful match.")
452;; Much modification of the kill (ahem, score) code and lots of the 474;; Much modification of the kill (ahem, score) code and lots of the
453;; functions are written by Per Abrahamsen <amanda@iesd.auc.dk>. 475;; functions are written by Per Abrahamsen <amanda@iesd.auc.dk>.
454 476
455(defun gnus-summary-lower-score (&optional score) 477(defun gnus-summary-lower-score (&optional score symp)
456 "Make a score entry based on the current article. 478 "Make a score entry based on the current article.
457The user will be prompted for header to score on, match type, 479The user will be prompted for header to score on, match type,
458permanence, and the string to be used. The numerical prefix will be 480permanence, and the string to be used. The numerical prefix will be
459used as score." 481used as score."
460 (interactive "P") 482 (interactive (gnus-interactive "P\ny"))
461 (gnus-summary-increase-score (- (gnus-score-default score)))) 483 (gnus-summary-increase-score (- (gnus-score-default score)) symp))
462 484
463(defun gnus-score-kill-help-buffer () 485(defun gnus-score-kill-help-buffer ()
464 (when (get-buffer "*Score Help*") 486 (when (get-buffer "*Score Help*")
@@ -466,13 +488,12 @@ used as score."
466 (when gnus-score-help-winconf 488 (when gnus-score-help-winconf
467 (set-window-configuration gnus-score-help-winconf)))) 489 (set-window-configuration gnus-score-help-winconf))))
468 490
469(defun gnus-summary-increase-score (&optional score) 491(defun gnus-summary-increase-score (&optional score symp)
470 "Make a score entry based on the current article. 492 "Make a score entry based on the current article.
471The user will be prompted for header to score on, match type, 493The user will be prompted for header to score on, match type,
472permanence, and the string to be used. The numerical prefix will be 494permanence, and the string to be used. The numerical prefix will be
473used as score." 495used as score."
474 (interactive "P") 496 (interactive (gnus-interactive "P\ny"))
475 (gnus-set-global-variables)
476 (let* ((nscore (gnus-score-default score)) 497 (let* ((nscore (gnus-score-default score))
477 (prefix (if (< nscore 0) ?L ?I)) 498 (prefix (if (< nscore 0) ?L ?I))
478 (increase (> nscore 0)) 499 (increase (> nscore 0))
@@ -482,12 +503,12 @@ used as score."
482 (?b "body" "" nil body-string) 503 (?b "body" "" nil body-string)
483 (?h "head" "" nil body-string) 504 (?h "head" "" nil body-string)
484 (?i "message-id" nil t string) 505 (?i "message-id" nil t string)
485 (?t "references" "message-id" nil string) 506 (?r "references" "message-id" nil string)
486 (?x "xref" nil nil string) 507 (?x "xref" nil nil string)
487 (?l "lines" nil nil number) 508 (?l "lines" nil nil number)
488 (?d "date" nil nil date) 509 (?d "date" nil nil date)
489 (?f "followup" nil nil string) 510 (?f "followup" nil nil string)
490 (?T "thread" nil nil string))) 511 (?t "thread" "message-id" nil string)))
491 (char-to-type 512 (char-to-type
492 '((?s s "substring" string) 513 '((?s s "substring" string)
493 (?e e "exact string" string) 514 (?e e "exact string" string)
@@ -496,11 +517,12 @@ used as score."
496 (?z s "substring" body-string) 517 (?z s "substring" body-string)
497 (?p r "regexp string" body-string) 518 (?p r "regexp string" body-string)
498 (?b before "before date" date) 519 (?b before "before date" date)
499 (?a at "at date" date) 520 (?a after "after date" date)
500 (?n now "this date" date) 521 (?n at "this date" date)
501 (?< < "less than number" number) 522 (?< < "less than number" number)
502 (?> > "greater than number" number) 523 (?> > "greater than number" number)
503 (?= = "equal to number" number))) 524 (?= = "equal to number" number)))
525 (current-score-file gnus-current-score-file)
504 (char-to-perm 526 (char-to-perm
505 (list (list ?t (current-time-string) "temporary") 527 (list (list ?t (current-time-string) "temporary")
506 '(?p perm "permanent") '(?i now "immediate"))) 528 '(?p perm "permanent") '(?i now "immediate")))
@@ -572,7 +594,7 @@ used as score."
572 ;; It was a majuscule, so we end reading and use the default. 594 ;; It was a majuscule, so we end reading and use the default.
573 (if mimic (message "%c %c %c" prefix hchar tchar) 595 (if mimic (message "%c %c %c" prefix hchar tchar)
574 (message "")) 596 (message ""))
575 (setq pchar (or pchar ?p))) 597 (setq pchar (or pchar ?t)))
576 598
577 ;; We continue reading. 599 ;; We continue reading.
578 (while (not pchar) 600 (while (not pchar)
@@ -618,6 +640,21 @@ used as score."
618 (when (memq type '(r R regexp Regexp)) 640 (when (memq type '(r R regexp Regexp))
619 (setq match (regexp-quote match))) 641 (setq match (regexp-quote match)))
620 642
643 ;; Change score file to the "all.SCORE" file.
644 (when (eq symp 'a)
645 (save-excursion
646 (set-buffer gnus-summary-buffer)
647 (gnus-score-load-file
648 ;; This is a kludge; yes...
649 (cond
650 ((eq gnus-score-find-score-files-function
651 'gnus-score-find-hierarchical)
652 (gnus-score-file-name ""))
653 ((eq gnus-score-find-score-files-function 'gnus-score-find-single)
654 current-score-file)
655 (t
656 (gnus-score-file-name "all"))))))
657
621 (gnus-summary-score-entry 658 (gnus-summary-score-entry
622 (nth 1 entry) ; Header 659 (nth 1 entry) ; Header
623 match ; Match 660 match ; Match
@@ -627,12 +664,17 @@ used as score."
627 nil 664 nil
628 temporary) 665 temporary)
629 (not (nth 3 entry))) ; Prompt 666 (not (nth 3 entry))) ; Prompt
630 )) 667
668 (when (eq symp 'a)
669 ;; We change the score file back to the previous one.
670 (save-excursion
671 (set-buffer gnus-summary-buffer)
672 (gnus-score-load-file current-score-file)))))
631 673
632(defun gnus-score-insert-help (string alist idx) 674(defun gnus-score-insert-help (string alist idx)
633 (setq gnus-score-help-winconf (current-window-configuration)) 675 (setq gnus-score-help-winconf (current-window-configuration))
634 (save-excursion 676 (save-excursion
635 (set-buffer (get-buffer-create "*Score Help*")) 677 (set-buffer (gnus-get-buffer-create "*Score Help*"))
636 (buffer-disable-undo (current-buffer)) 678 (buffer-disable-undo (current-buffer))
637 (delete-windows-on (current-buffer)) 679 (delete-windows-on (current-buffer))
638 (erase-buffer) 680 (erase-buffer)
@@ -712,20 +754,6 @@ SCORE is the score to add.
712DATE is the expire date, or nil for no expire, or 'now for immediate expire. 754DATE is the expire date, or nil for no expire, or 'now for immediate expire.
713If optional argument `PROMPT' is non-nil, allow user to edit match. 755If optional argument `PROMPT' is non-nil, allow user to edit match.
714If optional argument `SILENT' is nil, show effect of score entry." 756If optional argument `SILENT' is nil, show effect of score entry."
715 (interactive
716 (list (completing-read "Header: "
717 gnus-header-index
718 (lambda (x) (fboundp (nth 2 x)))
719 t)
720 (read-string "Match: ")
721 (if (y-or-n-p "Use regexp match? ") 'r 's)
722 (and current-prefix-arg
723 (prefix-numeric-value current-prefix-arg))
724 (cond ((not (y-or-n-p "Add to score file? "))
725 'now)
726 ((y-or-n-p "Expire kill? ")
727 (current-time-string))
728 (t nil))))
729 ;; Regexp is the default type. 757 ;; Regexp is the default type.
730 (when (eq type t) 758 (when (eq type t)
731 (setq type 'r)) 759 (setq type 'r))
@@ -788,7 +816,7 @@ If optional argument `SILENT' is nil, show effect of score entry."
788 (or (nth 1 new) 816 (or (nth 1 new)
789 gnus-score-interactive-default-score))) 817 gnus-score-interactive-default-score)))
790 ;; Nope, we have to add a new elem. 818 ;; Nope, we have to add a new elem.
791 (gnus-score-set header (if old (cons new old) (list new)))) 819 (gnus-score-set header (if old (cons new old) (list new)) nil t))
792 (gnus-score-set 'touched '(t)))) 820 (gnus-score-set 'touched '(t))))
793 821
794 ;; Score the current buffer. 822 ;; Score the current buffer.
@@ -938,7 +966,7 @@ SCORE is the score to add."
938 "references" id 's 966 "references" id 's
939 score (current-time-string)))))))) 967 score (current-time-string))))))))
940 968
941(defun gnus-score-set (symbol value &optional alist) 969(defun gnus-score-set (symbol value &optional alist warn)
942 ;; Set SYMBOL to VALUE in ALIST. 970 ;; Set SYMBOL to VALUE in ALIST.
943 (let* ((alist 971 (let* ((alist
944 (or alist 972 (or alist
@@ -947,7 +975,8 @@ SCORE is the score to add."
947 (entry (assoc symbol alist))) 975 (entry (assoc symbol alist)))
948 (cond ((gnus-score-get 'read-only alist) 976 (cond ((gnus-score-get 'read-only alist)
949 ;; This is a read-only score file, so we do nothing. 977 ;; This is a read-only score file, so we do nothing.
950 ) 978 (when warn
979 (gnus-message 4 "Note: read-only score file; entry discarded")))
951 (entry 980 (entry
952 (setcdr entry value)) 981 (setcdr entry value))
953 ((null alist) 982 ((null alist)
@@ -959,14 +988,12 @@ SCORE is the score to add."
959(defun gnus-summary-raise-score (n) 988(defun gnus-summary-raise-score (n)
960 "Raise the score of the current article by N." 989 "Raise the score of the current article by N."
961 (interactive "p") 990 (interactive "p")
962 (gnus-set-global-variables)
963 (gnus-summary-set-score (+ (gnus-summary-article-score) 991 (gnus-summary-set-score (+ (gnus-summary-article-score)
964 (or n gnus-score-interactive-default-score )))) 992 (or n gnus-score-interactive-default-score ))))
965 993
966(defun gnus-summary-set-score (n) 994(defun gnus-summary-set-score (n)
967 "Set the score of the current article to N." 995 "Set the score of the current article to N."
968 (interactive "p") 996 (interactive "p")
969 (gnus-set-global-variables)
970 (save-excursion 997 (save-excursion
971 (gnus-summary-show-thread) 998 (gnus-summary-show-thread)
972 (let ((buffer-read-only nil)) 999 (let ((buffer-read-only nil))
@@ -985,7 +1012,6 @@ SCORE is the score to add."
985(defun gnus-summary-current-score () 1012(defun gnus-summary-current-score ()
986 "Return the score of the current article." 1013 "Return the score of the current article."
987 (interactive) 1014 (interactive)
988 (gnus-set-global-variables)
989 (gnus-message 1 "%s" (gnus-summary-article-score))) 1015 (gnus-message 1 "%s" (gnus-summary-article-score)))
990 1016
991(defun gnus-score-change-score-file (file) 1017(defun gnus-score-change-score-file (file)
@@ -999,21 +1025,21 @@ SCORE is the score to add."
999(defun gnus-score-edit-current-scores (file) 1025(defun gnus-score-edit-current-scores (file)
1000 "Edit the current score alist." 1026 "Edit the current score alist."
1001 (interactive (list gnus-current-score-file)) 1027 (interactive (list gnus-current-score-file))
1002 (gnus-set-global-variables) 1028 (if (not gnus-current-score-file)
1003 (let ((winconf (current-window-configuration))) 1029 (error "No current score file")
1004 (when (buffer-name gnus-summary-buffer) 1030 (let ((winconf (current-window-configuration)))
1005 (gnus-score-save)) 1031 (when (buffer-name gnus-summary-buffer)
1006 (gnus-make-directory (file-name-directory file)) 1032 (gnus-score-save))
1007 (setq gnus-score-edit-buffer (find-file-noselect file)) 1033 (gnus-make-directory (file-name-directory file))
1008 (gnus-configure-windows 'edit-score) 1034 (setq gnus-score-edit-buffer (find-file-noselect file))
1009 (select-window (get-buffer-window gnus-score-edit-buffer)) 1035 (gnus-configure-windows 'edit-score)
1010 (gnus-score-mode) 1036 (gnus-score-mode)
1011 (setq gnus-score-edit-exit-function 'gnus-score-edit-done) 1037 (setq gnus-score-edit-exit-function 'gnus-score-edit-done)
1012 (make-local-variable 'gnus-prev-winconf) 1038 (make-local-variable 'gnus-prev-winconf)
1013 (setq gnus-prev-winconf winconf)) 1039 (setq gnus-prev-winconf winconf))
1014 (gnus-message 1040 (gnus-message
1015 4 (substitute-command-keys 1041 4 (substitute-command-keys
1016 "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits"))) 1042 "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits"))))
1017 1043
1018(defun gnus-score-edit-file (file) 1044(defun gnus-score-edit-file (file)
1019 "Edit a score file." 1045 "Edit a score file."
@@ -1037,8 +1063,9 @@ SCORE is the score to add."
1037 ;; Load score file FILE. Returns a list a retrieved score-alists. 1063 ;; Load score file FILE. Returns a list a retrieved score-alists.
1038 (let* ((file (expand-file-name 1064 (let* ((file (expand-file-name
1039 (or (and (string-match 1065 (or (and (string-match
1040 (concat "^" (expand-file-name 1066 (concat "^" (regexp-quote
1041 gnus-kill-files-directory)) 1067 (expand-file-name
1068 gnus-kill-files-directory)))
1042 (expand-file-name file)) 1069 (expand-file-name file))
1043 file) 1070 file)
1044 (concat (file-name-as-directory gnus-kill-files-directory) 1071 (concat (file-name-as-directory gnus-kill-files-directory)
@@ -1065,9 +1092,13 @@ SCORE is the score to add."
1065 found) 1092 found)
1066 (while a 1093 (while a
1067 ;; Downcase all header names. 1094 ;; Downcase all header names.
1068 (when (stringp (caar a)) 1095 (cond
1096 ((stringp (caar a))
1069 (setcar (car a) (downcase (caar a))) 1097 (setcar (car a) (downcase (caar a)))
1070 (setq found t)) 1098 (setq found t))
1099 ;; Advanced scoring.
1100 ((consp (caar a))
1101 (setq found t)))
1071 (pop a)) 1102 (pop a))
1072 ;; If there are actual scores in the alist, we add it to the 1103 ;; If there are actual scores in the alist, we add it to the
1073 ;; return value of this function. 1104 ;; return value of this function.
@@ -1088,30 +1119,35 @@ SCORE is the score to add."
1088 (decay (car (gnus-score-get 'decay alist))) 1119 (decay (car (gnus-score-get 'decay alist)))
1089 (eval (car (gnus-score-get 'eval alist)))) 1120 (eval (car (gnus-score-get 'eval alist))))
1090 ;; Perform possible decays. 1121 ;; Perform possible decays.
1091 (when gnus-decay-scores 1122 (when (and gnus-decay-scores
1092 (when (or (not decay) 1123 (or cached (file-exists-p file))
1093 (gnus-decay-scores alist decay)) 1124 (or (not decay)
1094 (gnus-score-set 'touched '(t) alist) 1125 (gnus-decay-scores alist decay)))
1095 (gnus-score-set 'decay (list (gnus-time-to-day (current-time)))))) 1126 (gnus-score-set 'touched '(t) alist)
1127 (gnus-score-set 'decay (list (gnus-time-to-day (current-time))) alist))
1096 ;; We do not respect eval and files atoms from global score 1128 ;; We do not respect eval and files atoms from global score
1097 ;; files. 1129 ;; files.
1098 (and files (not global) 1130 (when (and files (not global))
1099 (setq lists (apply 'append lists 1131 (setq lists (apply 'append lists
1100 (mapcar (lambda (file) 1132 (mapcar (lambda (file)
1101 (gnus-score-load-file file)) 1133 (gnus-score-load-file file))
1102 (if adapt-file (cons adapt-file files) 1134 (if adapt-file (cons adapt-file files)
1103 files))))) 1135 files)))))
1104 (and eval (not global) (eval eval)) 1136 (when (and eval (not global))
1137 (eval eval))
1105 ;; We then expand any exclude-file directives. 1138 ;; We then expand any exclude-file directives.
1106 (setq gnus-scores-exclude-files 1139 (setq gnus-scores-exclude-files
1107 (nconc 1140 (nconc
1108 (mapcar 1141 (apply
1109 (lambda (sfile) 1142 'nconc
1110 (expand-file-name sfile (file-name-directory file))) 1143 (mapcar
1111 exclude-files) 1144 (lambda (sfile)
1145 (list
1146 (expand-file-name sfile (file-name-directory file))
1147 (expand-file-name sfile gnus-kill-files-directory)))
1148 exclude-files))
1112 gnus-scores-exclude-files)) 1149 gnus-scores-exclude-files))
1113 (if (not local) 1150 (when local
1114 ()
1115 (save-excursion 1151 (save-excursion
1116 (set-buffer gnus-summary-buffer) 1152 (set-buffer gnus-summary-buffer)
1117 (while local 1153 (while local
@@ -1180,10 +1216,16 @@ SCORE is the score to add."
1180 (read (current-buffer)) 1216 (read (current-buffer))
1181 (error 1217 (error
1182 (gnus-error 3.2 "Problem with score file %s" file)))))) 1218 (gnus-error 3.2 "Problem with score file %s" file))))))
1183 (if (eq (car alist) 'setq) 1219 (cond
1184 ;; This is an old-style score file. 1220 ((and alist
1185 (setq gnus-score-alist (gnus-score-transform-old-to-new alist)) 1221 (atom alist))
1186 (setq gnus-score-alist alist)) 1222 ;; Bogus score file.
1223 (error "Invalid syntax with score file %s" file))
1224 ((eq (car alist) 'setq)
1225 ;; This is an old-style score file.
1226 (setq gnus-score-alist (gnus-score-transform-old-to-new alist)))
1227 (t
1228 (setq gnus-score-alist alist)))
1187 ;; Check the syntax of the score file. 1229 ;; Check the syntax of the score file.
1188 (setq gnus-score-alist 1230 (setq gnus-score-alist
1189 (gnus-score-check-syntax gnus-score-alist file))))) 1231 (gnus-score-check-syntax gnus-score-alist file)))))
@@ -1278,7 +1320,7 @@ SCORE is the score to add."
1278 (and (file-exists-p file) 1320 (and (file-exists-p file)
1279 (not (file-writable-p file)))) 1321 (not (file-writable-p file))))
1280 () 1322 ()
1281 (setq score (setcdr entry (delq (assq 'touched score) score))) 1323 (setq score (setcdr entry (gnus-delete-alist 'touched score)))
1282 (erase-buffer) 1324 (erase-buffer)
1283 (let (emacs-lisp-mode-hook) 1325 (let (emacs-lisp-mode-hook)
1284 (if (string-match 1326 (if (string-match
@@ -1290,7 +1332,8 @@ SCORE is the score to add."
1290 (gnus-prin1 score) 1332 (gnus-prin1 score)
1291 ;; This is a normal score file, so we print it very 1333 ;; This is a normal score file, so we print it very
1292 ;; prettily. 1334 ;; prettily.
1293 (pp score (current-buffer)))) 1335 (let ((lisp-mode-syntax-table score-mode-syntax-table))
1336 (pp score (current-buffer)))))
1294 (gnus-make-directory (file-name-directory file)) 1337 (gnus-make-directory (file-name-directory file))
1295 ;; If the score file is empty, we delete it. 1338 ;; If the score file is empty, we delete it.
1296 (if (zerop (buffer-size)) 1339 (if (zerop (buffer-size))
@@ -1363,9 +1406,10 @@ SCORE is the score to add."
1363 gnus-scores-articles)))) 1406 gnus-scores-articles))))
1364 1407
1365 (save-excursion 1408 (save-excursion
1366 (set-buffer (get-buffer-create "*Headers*")) 1409 (set-buffer (gnus-get-buffer-create "*Headers*"))
1367 (buffer-disable-undo (current-buffer)) 1410 (buffer-disable-undo (current-buffer))
1368 (message-clone-locals gnus-summary-buffer) 1411 (when (gnus-buffer-live-p gnus-summary-buffer)
1412 (message-clone-locals gnus-summary-buffer))
1369 1413
1370 ;; Set the global variant of this variable. 1414 ;; Set the global variant of this variable.
1371 (setq gnus-current-score-file current-score-file) 1415 (setq gnus-current-score-file current-score-file)
@@ -1616,7 +1660,7 @@ SCORE is the score to add."
1616 (setq request-func 'gnus-request-article)) 1660 (setq request-func 'gnus-request-article))
1617 (while articles 1661 (while articles
1618 (setq article (mail-header-number (caar articles))) 1662 (setq article (mail-header-number (caar articles)))
1619 (gnus-message 7 "Scoring on article %s of %s..." article last) 1663 (gnus-message 7 "Scoring article %s of %s..." article last)
1620 (when (funcall request-func article gnus-newsgroup-name) 1664 (when (funcall request-func article gnus-newsgroup-name)
1621 (widen) 1665 (widen)
1622 (goto-char (point-min)) 1666 (goto-char (point-min))
@@ -1812,6 +1856,8 @@ SCORE is the score to add."
1812 ;; Insert the unique article headers in the buffer. 1856 ;; Insert the unique article headers in the buffer.
1813 (let ((gnus-score-index (nth 1 (assoc header gnus-header-index))) 1857 (let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
1814 ;; gnus-score-index is used as a free variable. 1858 ;; gnus-score-index is used as a free variable.
1859 (simplify (and gnus-score-thread-simplify
1860 (string= "subject" header)))
1815 alike last this art entries alist articles 1861 alike last this art entries alist articles
1816 fuzzies arts words kill) 1862 fuzzies arts words kill)
1817 1863
@@ -1827,6 +1873,8 @@ SCORE is the score to add."
1827 (erase-buffer) 1873 (erase-buffer)
1828 (while (setq art (pop articles)) 1874 (while (setq art (pop articles))
1829 (setq this (aref (car art) gnus-score-index)) 1875 (setq this (aref (car art) gnus-score-index))
1876 (if simplify
1877 (setq this (gnus-map-function gnus-simplify-subject-functions this)))
1830 (if (equal last this) 1878 (if (equal last this)
1831 ;; O(N*H) cons-cells used here, where H is the number of 1879 ;; O(N*H) cons-cells used here, where H is the number of
1832 ;; headers. 1880 ;; headers.
@@ -1852,7 +1900,6 @@ SCORE is the score to add."
1852 entries (assoc header alist)) 1900 entries (assoc header alist))
1853 (while (cdr entries) ;First entry is the header index. 1901 (while (cdr entries) ;First entry is the header index.
1854 (let* ((kill (cadr entries)) 1902 (let* ((kill (cadr entries))
1855 (match (nth 0 kill))
1856 (type (or (nth 3 kill) 's)) 1903 (type (or (nth 3 kill) 's))
1857 (score (or (nth 1 kill) gnus-score-interactive-default-score)) 1904 (score (or (nth 1 kill) gnus-score-interactive-default-score))
1858 (date (nth 2 kill)) 1905 (date (nth 2 kill))
@@ -1860,6 +1907,12 @@ SCORE is the score to add."
1860 (mt (aref (symbol-name type) 0)) 1907 (mt (aref (symbol-name type) 0))
1861 (case-fold-search (not (memq mt '(?R ?S ?E ?F)))) 1908 (case-fold-search (not (memq mt '(?R ?S ?E ?F))))
1862 (dmt (downcase mt)) 1909 (dmt (downcase mt))
1910 ; Assume user already simplified regexp and fuzzies
1911 (match (if (and simplify (not (memq dmt '(?f ?r))))
1912 (gnus-map-function
1913 gnus-simplify-subject-functions
1914 (nth 0 kill))
1915 (nth 0 kill)))
1863 (search-func 1916 (search-func
1864 (cond ((= dmt ?r) 're-search-forward) 1917 (cond ((= dmt ?r) 're-search-forward)
1865 ((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward) 1918 ((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward)
@@ -1868,10 +1921,12 @@ SCORE is the score to add."
1868 (cond 1921 (cond
1869 ;; Fuzzy matches. We save these for later. 1922 ;; Fuzzy matches. We save these for later.
1870 ((= dmt ?f) 1923 ((= dmt ?f)
1871 (push (cons entries alist) fuzzies)) 1924 (push (cons entries alist) fuzzies)
1925 (setq entries (cdr entries)))
1872 ;; Word matches. Save these for even later. 1926 ;; Word matches. Save these for even later.
1873 ((= dmt ?w) 1927 ((= dmt ?w)
1874 (push (cons entries alist) words)) 1928 (push (cons entries alist) words)
1929 (setq entries (cdr entries)))
1875 ;; Exact matches. 1930 ;; Exact matches.
1876 ((= dmt ?e) 1931 ((= dmt ?e)
1877 ;; Do exact matching. 1932 ;; Do exact matching.
@@ -1896,7 +1951,26 @@ SCORE is the score to add."
1896 gnus-score-trace)) 1951 gnus-score-trace))
1897 (while (setq art (pop arts)) 1952 (while (setq art (pop arts))
1898 (setcdr art (+ score (cdr art))))))) 1953 (setcdr art (+ score (cdr art)))))))
1899 (forward-line 1))) 1954 (forward-line 1))
1955 ;; Update expiry date
1956 (if trace
1957 (setq entries (cdr entries))
1958 (cond
1959 ;; Permanent entry.
1960 ((null date)
1961 (setq entries (cdr entries)))
1962 ;; We have a match, so we update the date.
1963 ((and found gnus-update-score-entry-dates)
1964 (gnus-score-set 'touched '(t) alist)
1965 (setcar (nthcdr 2 kill) now)
1966 (setq entries (cdr entries)))
1967 ;; This entry has expired, so we remove it.
1968 ((and expire (< date expire))
1969 (gnus-score-set 'touched '(t) alist)
1970 (setcdr entries (cddr entries)))
1971 ;; No match; go to next entry.
1972 (t
1973 (setq entries (cdr entries))))))
1900 ;; Regexp and substring matching. 1974 ;; Regexp and substring matching.
1901 (t 1975 (t
1902 (goto-char (point-min)) 1976 (goto-char (point-min))
@@ -1915,26 +1989,26 @@ SCORE is the score to add."
1915 gnus-score-trace)) 1989 gnus-score-trace))
1916 (while (setq art (pop arts)) 1990 (while (setq art (pop arts))
1917 (setcdr art (+ score (cdr art))))) 1991 (setcdr art (+ score (cdr art)))))
1918 (forward-line 1)))) 1992 (forward-line 1))
1919 ;; Update expiry date 1993 ;; Update expiry date
1920 (if trace 1994 (if trace
1921 (setq entries (cdr entries)) 1995 (setq entries (cdr entries))
1922 (cond 1996 (cond
1923 ;; Permanent entry. 1997 ;; Permanent entry.
1924 ((null date) 1998 ((null date)
1925 (setq entries (cdr entries))) 1999 (setq entries (cdr entries)))
1926 ;; We have a match, so we update the date. 2000 ;; We have a match, so we update the date.
1927 ((and found gnus-update-score-entry-dates) 2001 ((and found gnus-update-score-entry-dates)
1928 (gnus-score-set 'touched '(t) alist) 2002 (gnus-score-set 'touched '(t) alist)
1929 (setcar (nthcdr 2 kill) now) 2003 (setcar (nthcdr 2 kill) now)
1930 (setq entries (cdr entries))) 2004 (setq entries (cdr entries)))
1931 ;; This entry has expired, so we remove it. 2005 ;; This entry has expired, so we remove it.
1932 ((and expire (< date expire)) 2006 ((and expire (< date expire))
1933 (gnus-score-set 'touched '(t) alist) 2007 (gnus-score-set 'touched '(t) alist)
1934 (setcdr entries (cddr entries))) 2008 (setcdr entries (cddr entries)))
1935 ;; No match; go to next entry. 2009 ;; No match; go to next entry.
1936 (t 2010 (t
1937 (setq entries (cdr entries)))))))) 2011 (setq entries (cdr entries))))))))))
1938 2012
1939 ;; Find fuzzy matches. 2013 ;; Find fuzzy matches.
1940 (when fuzzies 2014 (when fuzzies
@@ -1966,18 +2040,19 @@ SCORE is the score to add."
1966 (setcdr art (+ score (cdr art)))))) 2040 (setcdr art (+ score (cdr art))))))
1967 (forward-line 1)) 2041 (forward-line 1))
1968 ;; Update expiry date 2042 ;; Update expiry date
1969 (cond 2043 (if (not trace)
1970 ;; Permanent. 2044 (cond
1971 ((null date) 2045 ;; Permanent.
1972 ) 2046 ((null date)
1973 ;; Match, update date. 2047 )
1974 ((and found gnus-update-score-entry-dates) 2048 ;; Match, update date.
1975 (gnus-score-set 'touched '(t) (cdar fuzzies)) 2049 ((and found gnus-update-score-entry-dates)
1976 (setcar (nthcdr 2 kill) now)) 2050 (gnus-score-set 'touched '(t) (cdar fuzzies))
1977 ;; Old entry, remove. 2051 (setcar (nthcdr 2 kill) now))
1978 ((and expire (< date expire)) 2052 ;; Old entry, remove.
1979 (gnus-score-set 'touched '(t) (cdar fuzzies)) 2053 ((and expire (< date expire))
1980 (setcdr (caar fuzzies) (cddaar fuzzies)))) 2054 (gnus-score-set 'touched '(t) (cdar fuzzies))
2055 (setcdr (caar fuzzies) (cddaar fuzzies)))))
1981 (setq fuzzies (cdr fuzzies))))) 2056 (setq fuzzies (cdr fuzzies)))))
1982 2057
1983 (when words 2058 (when words
@@ -2003,18 +2078,19 @@ SCORE is the score to add."
2003 (while (setq art (pop arts)) 2078 (while (setq art (pop arts))
2004 (setcdr art (+ score (cdr art)))))) 2079 (setcdr art (+ score (cdr art))))))
2005 ;; Update expiry date 2080 ;; Update expiry date
2006 (cond 2081 (if (not trace)
2007 ;; Permanent. 2082 (cond
2008 ((null date) 2083 ;; Permanent.
2009 ) 2084 ((null date)
2010 ;; Match, update date. 2085 )
2011 ((and found gnus-update-score-entry-dates) 2086 ;; Match, update date.
2012 (gnus-score-set 'touched '(t) (cdar words)) 2087 ((and found gnus-update-score-entry-dates)
2013 (setcar (nthcdr 2 kill) now)) 2088 (gnus-score-set 'touched '(t) (cdar words))
2014 ;; Old entry, remove. 2089 (setcar (nthcdr 2 kill) now))
2015 ((and expire (< date expire)) 2090 ;; Old entry, remove.
2016 (gnus-score-set 'touched '(t) (cdar words)) 2091 ((and expire (< date expire))
2017 (setcdr (caar words) (cddaar words)))) 2092 (gnus-score-set 'touched '(t) (cdar words))
2093 (setcdr (caar words) (cddaar words)))))
2018 (setq words (cdr words)))))) 2094 (setq words (cdr words))))))
2019 nil)) 2095 nil))
2020 2096
@@ -2040,6 +2116,10 @@ SCORE is the score to add."
2040 (set-syntax-table syntab)) 2116 (set-syntax-table syntab))
2041 ;; Make all the ignorable words ignored. 2117 ;; Make all the ignorable words ignored.
2042 (let ((ignored (append gnus-ignored-adaptive-words 2118 (let ((ignored (append gnus-ignored-adaptive-words
2119 (if gnus-adaptive-word-no-group-words
2120 (message-tokenize-header
2121 (gnus-group-real-name gnus-newsgroup-name)
2122 "."))
2043 gnus-default-ignored-adaptive-words))) 2123 gnus-default-ignored-adaptive-words)))
2044 (while ignored 2124 (while ignored
2045 (gnus-sethash (pop ignored) nil hashtb))))) 2125 (gnus-sethash (pop ignored) nil hashtb)))))
@@ -2064,6 +2144,7 @@ SCORE is the score to add."
2064 (set-buffer gnus-summary-buffer) 2144 (set-buffer gnus-summary-buffer)
2065 (gnus-score-load-file 2145 (gnus-score-load-file
2066 (or gnus-newsgroup-adaptive-score-file 2146 (or gnus-newsgroup-adaptive-score-file
2147 (gnus-home-score-file gnus-newsgroup-name t)
2067 (gnus-score-file-name 2148 (gnus-score-file-name
2068 gnus-newsgroup-name gnus-adaptive-file-suffix)))) 2149 gnus-newsgroup-name gnus-adaptive-file-suffix))))
2069 ;; Perform ordinary line scoring. 2150 ;; Perform ordinary line scoring.
@@ -2074,7 +2155,7 @@ SCORE is the score to add."
2074 (alist malist) 2155 (alist malist)
2075 (date (current-time-string)) 2156 (date (current-time-string))
2076 (data gnus-newsgroup-data) 2157 (data gnus-newsgroup-data)
2077 elem headers match) 2158 elem headers match func)
2078 ;; First we transform the adaptive rule alist into something 2159 ;; First we transform the adaptive rule alist into something
2079 ;; that's faster to process. 2160 ;; that's faster to process.
2080 (while malist 2161 (while malist
@@ -2083,19 +2164,21 @@ SCORE is the score to add."
2083 (setcar elem (symbol-value (car elem)))) 2164 (setcar elem (symbol-value (car elem))))
2084 (setq elem (cdr elem)) 2165 (setq elem (cdr elem))
2085 (while elem 2166 (while elem
2086 (setcdr (car elem) 2167 (when (fboundp
2087 (cons (if (eq (caar elem) 'followup) 2168 (setq func
2088 "references" 2169 (intern
2089 (symbol-name (caar elem)))
2090 (cdar elem)))
2091 (setcar (car elem)
2092 `(lambda (h)
2093 (,(intern
2094 (concat "mail-header-" 2170 (concat "mail-header-"
2095 (if (eq (caar elem) 'followup) 2171 (if (eq (caar elem) 'followup)
2096 "message-id" 2172 "message-id"
2097 (downcase (symbol-name (caar elem)))))) 2173 (downcase (symbol-name (caar elem))))))))
2098 h))) 2174 (setcdr (car elem)
2175 (cons (if (eq (caar elem) 'followup)
2176 "references"
2177 (symbol-name (caar elem)))
2178 (cdar elem)))
2179 (setcar (car elem)
2180 `(lambda (h)
2181 (,func h))))
2099 (setq elem (cdr elem))) 2182 (setq elem (cdr elem)))
2100 (setq malist (cdr malist))) 2183 (setq malist (cdr malist)))
2101 ;; Then we score away. 2184 ;; Then we score away.
@@ -2156,11 +2239,20 @@ SCORE is the score to add."
2156 ;; Put the word and score into the hashtb. 2239 ;; Put the word and score into the hashtb.
2157 (setq val (gnus-gethash (setq word (match-string 0)) 2240 (setq val (gnus-gethash (setq word (match-string 0))
2158 hashtb)) 2241 hashtb))
2159 (gnus-sethash word (+ (or val 0) score) hashtb)) 2242 (setq val (+ score (or val 0)))
2243 (if (and gnus-adaptive-word-minimum
2244 (< val gnus-adaptive-word-minimum))
2245 (setq val gnus-adaptive-word-minimum))
2246 (gnus-sethash word val hashtb))
2160 (erase-buffer)))) 2247 (erase-buffer))))
2161 (set-syntax-table syntab)) 2248 (set-syntax-table syntab))
2162 ;; Make all the ignorable words ignored. 2249 ;; Make all the ignorable words ignored.
2163 (let ((ignored (append gnus-ignored-adaptive-words 2250 (let ((ignored (append gnus-ignored-adaptive-words
2251 (if gnus-adaptive-word-no-group-words
2252 (message-tokenize-header
2253 (gnus-group-real-name
2254 gnus-newsgroup-name)
2255 "."))
2164 gnus-default-ignored-adaptive-words))) 2256 gnus-default-ignored-adaptive-words)))
2165 (while ignored 2257 (while ignored
2166 (gnus-sethash (pop ignored) nil hashtb))) 2258 (gnus-sethash (pop ignored) nil hashtb)))
@@ -2200,7 +2292,6 @@ SCORE is the score to add."
2200 1 "No score rules apply to the current article (default score %d)." 2292 1 "No score rules apply to the current article (default score %d)."
2201 gnus-summary-default-score) 2293 gnus-summary-default-score)
2202 (set-buffer "*Score Trace*") 2294 (set-buffer "*Score Trace*")
2203 (gnus-add-current-to-buffer-list)
2204 (while trace 2295 (while trace
2205 (insert (format "%S -> %s\n" (cdar trace) 2296 (insert (format "%S -> %s\n" (cdar trace)
2206 (if (caar trace) 2297 (if (caar trace)
@@ -2246,7 +2337,6 @@ SCORE is the score to add."
2246 (while rules 2337 (while rules
2247 (insert (format "%-5d: %s\n" (caar rules) (cdar rules))) 2338 (insert (format "%-5d: %s\n" (caar rules) (cdar rules)))
2248 (pop rules)) 2339 (pop rules))
2249 (gnus-add-current-to-buffer-list)
2250 (goto-char (point-min)) 2340 (goto-char (point-min))
2251 (gnus-configure-windows 'score-words)))) 2341 (gnus-configure-windows 'score-words))))
2252 2342
@@ -2417,7 +2507,7 @@ GROUP using BNews sys file syntax."
2417 (trans (cdr (assq ?: nnheader-file-name-translation-alist))) 2507 (trans (cdr (assq ?: nnheader-file-name-translation-alist)))
2418 ofiles not-match regexp) 2508 ofiles not-match regexp)
2419 (save-excursion 2509 (save-excursion
2420 (set-buffer (get-buffer-create "*gnus score files*")) 2510 (set-buffer (gnus-get-buffer-create "*gnus score files*"))
2421 (buffer-disable-undo (current-buffer)) 2511 (buffer-disable-undo (current-buffer))
2422 ;; Go through all score file names and create regexp with them 2512 ;; Go through all score file names and create regexp with them
2423 ;; as the source. 2513 ;; as the source.
@@ -2546,7 +2636,7 @@ Destroys the current buffer."
2546 files))) 2636 files)))
2547 (mapcar 2637 (mapcar
2548 (lambda (f) (cdr f)) 2638 (lambda (f) (cdr f))
2549 (sort alist (lambda (f1 f2) (< (car f1) (car f2)))))))) 2639 (sort alist 'car-less-than-car)))))
2550 2640
2551(defun gnus-score-find-alist (group) 2641(defun gnus-score-find-alist (group)
2552 "Return list of score files for GROUP. 2642 "Return list of score files for GROUP.
@@ -2583,57 +2673,58 @@ The list is determined from the variable gnus-score-file-alist."
2583 (let ((funcs gnus-score-find-score-files-function) 2673 (let ((funcs gnus-score-find-score-files-function)
2584 (group (or group gnus-newsgroup-name)) 2674 (group (or group gnus-newsgroup-name))
2585 score-files) 2675 score-files)
2586 ;; Make sure funcs is a list. 2676 (when group
2587 (and funcs 2677 ;; Make sure funcs is a list.
2588 (not (listp funcs)) 2678 (and funcs
2589 (setq funcs (list funcs))) 2679 (not (listp funcs))
2590 ;; Get the initial score files for this group. 2680 (setq funcs (list funcs)))
2591 (when funcs 2681 ;; Get the initial score files for this group.
2592 (setq score-files (nreverse (gnus-score-find-alist group)))) 2682 (when funcs
2593 ;; Add any home adapt files. 2683 (setq score-files (nreverse (gnus-score-find-alist group))))
2594 (let ((home (gnus-home-score-file group t))) 2684 ;; Add any home adapt files.
2595 (when home 2685 (let ((home (gnus-home-score-file group t)))
2596 (push home score-files) 2686 (when home
2597 (setq gnus-newsgroup-adaptive-score-file home))) 2687 (push home score-files)
2598 ;; Check whether there is a `adapt-file' group parameter. 2688 (setq gnus-newsgroup-adaptive-score-file home)))
2599 (let ((param-file (gnus-group-find-parameter group 'adapt-file))) 2689 ;; Check whether there is a `adapt-file' group parameter.
2600 (when param-file 2690 (let ((param-file (gnus-group-find-parameter group 'adapt-file)))
2601 (push param-file score-files) 2691 (when param-file
2602 (setq gnus-newsgroup-adaptive-score-file param-file))) 2692 (push param-file score-files)
2603 ;; Go through all the functions for finding score files (or actual 2693 (setq gnus-newsgroup-adaptive-score-file param-file)))
2604 ;; scores) and add them to a list. 2694 ;; Go through all the functions for finding score files (or actual
2605 (while funcs 2695 ;; scores) and add them to a list.
2606 (when (gnus-functionp (car funcs)) 2696 (while funcs
2607 (setq score-files 2697 (when (gnus-functionp (car funcs))
2608 (nconc score-files (nreverse (funcall (car funcs) group))))) 2698 (setq score-files
2609 (setq funcs (cdr funcs))) 2699 (nconc score-files (nreverse (funcall (car funcs) group)))))
2610 ;; Add any home score files. 2700 (setq funcs (cdr funcs)))
2611 (let ((home (gnus-home-score-file group))) 2701 ;; Add any home score files.
2612 (when home 2702 (let ((home (gnus-home-score-file group)))
2613 (push home score-files))) 2703 (when home
2614 ;; Check whether there is a `score-file' group parameter. 2704 (push home score-files)))
2615 (let ((param-file (gnus-group-find-parameter group 'score-file))) 2705 ;; Check whether there is a `score-file' group parameter.
2616 (when param-file 2706 (let ((param-file (gnus-group-find-parameter group 'score-file)))
2617 (push param-file score-files))) 2707 (when param-file
2618 ;; Expand all files names. 2708 (push param-file score-files)))
2619 (let ((files score-files)) 2709 ;; Expand all files names.
2620 (while files 2710 (let ((files score-files))
2621 (when (stringp (car files)) 2711 (while files
2622 (setcar files (expand-file-name 2712 (when (stringp (car files))
2623 (car files) gnus-kill-files-directory))) 2713 (setcar files (expand-file-name
2624 (pop files))) 2714 (car files) gnus-kill-files-directory)))
2625 (setq score-files (nreverse score-files)) 2715 (pop files)))
2626 ;; Remove any duplicate score files. 2716 (setq score-files (nreverse score-files))
2627 (while (and score-files 2717 ;; Remove any duplicate score files.
2628 (member (car score-files) (cdr score-files))) 2718 (while (and score-files
2629 (pop score-files)) 2719 (member (car score-files) (cdr score-files)))
2630 (let ((files score-files)) 2720 (pop score-files))
2631 (while (cdr files) 2721 (let ((files score-files))
2632 (if (member (cadr files) (cddr files)) 2722 (while (cdr files)
2633 (setcdr files (cddr files)) 2723 (if (member (cadr files) (cddr files))
2634 (pop files)))) 2724 (setcdr files (cddr files))
2635 ;; Do the scoring if there are any score files for this group. 2725 (pop files))))
2636 score-files)) 2726 ;; Do the scoring if there are any score files for this group.
2727 score-files)))
2637 2728
2638(defun gnus-possibly-score-headers (&optional trace) 2729(defun gnus-possibly-score-headers (&optional trace)
2639 "Do scoring if scoring is required." 2730 "Do scoring if scoring is required."
@@ -2649,8 +2740,7 @@ The list is determined from the variable gnus-score-file-alist."
2649 ((or (null newsgroup) 2740 ((or (null newsgroup)
2650 (string-equal newsgroup "")) 2741 (string-equal newsgroup ""))
2651 ;; The global score file is placed at top of the directory. 2742 ;; The global score file is placed at top of the directory.
2652 (expand-file-name 2743 (expand-file-name suffix gnus-kill-files-directory))
2653 suffix gnus-kill-files-directory))
2654 ((gnus-use-long-file-name 'not-score) 2744 ((gnus-use-long-file-name 'not-score)
2655 ;; Append ".SCORE" to newsgroup name. 2745 ;; Append ".SCORE" to newsgroup name.
2656 (expand-file-name (concat (gnus-newsgroup-savable-name newsgroup) 2746 (expand-file-name (concat (gnus-newsgroup-savable-name newsgroup)
@@ -2669,6 +2759,7 @@ The list is determined from the variable gnus-score-file-alist."
2669 (interactive (list gnus-global-score-files)) 2759 (interactive (list gnus-global-score-files))
2670 (let (out) 2760 (let (out)
2671 (while files 2761 (while files
2762 ;; #### /$ Unix-specific?
2672 (if (string-match "/$" (car files)) 2763 (if (string-match "/$" (car files))
2673 (setq out (nconc (directory-files 2764 (setq out (nconc (directory-files
2674 (car files) t 2765 (car files) t
@@ -2708,8 +2799,8 @@ If ADAPT, return the home adaptive file instead."
2708 (funcall elem group)) 2799 (funcall elem group))
2709 ;; Regexp-file cons 2800 ;; Regexp-file cons
2710 ((consp elem) 2801 ((consp elem)
2711 (when (string-match (car elem) group) 2802 (when (string-match (gnus-globalify-regexp (car elem)) group)
2712 (cadr elem)))))) 2803 (replace-match (cadr elem) t nil group ))))))
2713 (when found 2804 (when found
2714 (nnheader-concat gnus-kill-files-directory found)))) 2805 (nnheader-concat gnus-kill-files-directory found))))
2715 2806
@@ -2729,6 +2820,10 @@ If ADAPT, return the home adaptive file instead."
2729 (concat group (if (gnus-use-long-file-name 'not-score) "." "/") 2820 (concat group (if (gnus-use-long-file-name 'not-score) "." "/")
2730 gnus-adaptive-file-suffix))) 2821 gnus-adaptive-file-suffix)))
2731 2822
2823(defun gnus-current-home-score-file (group)
2824 "Return the \"current\" regular score file."
2825 (car (nreverse (gnus-score-find-alist group))))
2826
2732;;; 2827;;;
2733;;; Score decays 2828;;; Score decays
2734;;; 2829;;;
@@ -2764,6 +2859,63 @@ If ADAPT, return the home adaptive file instead."
2764 ;; Return whether this score file needs to be saved. By Je-haysuss! 2859 ;; Return whether this score file needs to be saved. By Je-haysuss!
2765 updated)) 2860 updated))
2766 2861
2862(defun gnus-score-regexp-bad-p (regexp)
2863 "Test whether REGEXP is safe for Gnus scoring.
2864A regexp is unsafe if it matches newline or a buffer boundary.
2865
2866If the regexp is good, return nil. If the regexp is bad, return a
2867cons cell (SYM . STRING), where the symbol SYM is `new' or `bad'.
2868In the `new' case, the string is a safe replacement for REGEXP.
2869In the `bad' case, the string is a unsafe subexpression of REGEXP,
2870and we do not have a simple replacement to suggest.
2871
2872See `(Gnus)Scoring Tips' for examples of good regular expressions."
2873 (let (case-fold-search)
2874 (and
2875 ;; First, try a relatively fast necessary condition.
2876 ;; Notice ranges (like [^:] or [\t-\r]), \s>, \Sw, \W, \', \`:
2877 (string-match "\n\\|\\\\[SsW`']\\|\\[\\^\\|[\0-\n]-" regexp)
2878 ;; Now break the regexp into tokens, and check each:
2879 (let ((tail regexp) ; remaining regexp to check
2880 tok ; current token
2881 bad ; nil, or bad subexpression
2882 new ; nil, or replacement regexp so far
2883 end) ; length of current token
2884 (while (and (not bad)
2885 (string-match
2886 "\\`\\(\\\\[sS]?.\\|\\[\\^?]?[^]]*]\\|[^\\]\\)"
2887 tail))
2888 (setq end (match-end 0)
2889 tok (substring tail 0 end)
2890 tail (substring tail end))
2891 (if;; Is token `bad' (matching newline or buffer ends)?
2892 (or (member tok '("\n" "\\W" "\\`" "\\'"))
2893 ;; This next handles "[...]", "\\s.", and "\\S.":
2894 (and (> end 2) (string-match tok "\n")))
2895 (let ((newtok
2896 ;; Try to suggest a replacement for tok ...
2897 (cond ((string-equal tok "\\`") "^") ; or "\\(^\\)"
2898 ((string-equal tok "\\'") "$") ; or "\\($\\)"
2899 ((string-match "\\[\\^" tok) ; very common
2900 (concat (substring tok 0 -1) "\n]")))))
2901 (if newtok
2902 (setq new
2903 (concat
2904 (or new
2905 ;; good prefix so far:
2906 (substring regexp 0 (- (+ (length tail) end))))
2907 newtok))
2908 ;; No replacement idea, so give up:
2909 (setq bad tok)))
2910 ;; tok is good, may need to extend new
2911 (and new (setq new (concat new tok)))))
2912 ;; Now return a value:
2913 (cond
2914 (bad (cons 'bad bad))
2915 (new (cons 'new new))
2916 ;; or nil
2917 )))))
2918
2767(provide 'gnus-score) 2919(provide 'gnus-score)
2768 2920
2769;;; gnus-score.el ends here 2921;;; gnus-score.el ends here
diff --git a/lisp/gnus/gnus-soup.el b/lisp/gnus/gnus-soup.el
index 2143f9dc437..09b58a7c8a3 100644
--- a/lisp/gnus/gnus-soup.el
+++ b/lisp/gnus/gnus-soup.el
@@ -1,8 +1,8 @@
1;;; gnus-soup.el --- SOUP packet writing support for Gnus 1;;; gnus-soup.el --- SOUP packet writing support for Gnus
2;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. 2;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Per Abrahamsen <abraham@iesd.auc.dk> 4;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
5;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 5;; Lars Magne Ingebrigtsen <larsi@gnus.org>
6;; Keywords: news, mail 6;; Keywords: news, mail
7 7
8;; This file is part of GNU Emacs. 8;; This file is part of GNU Emacs.
@@ -28,6 +28,8 @@
28 28
29(eval-when-compile (require 'cl)) 29(eval-when-compile (require 'cl))
30 30
31(eval-when-compile (require 'cl))
32
31(require 'gnus) 33(require 'gnus)
32(require 'gnus-art) 34(require 'gnus-art)
33(require 'message) 35(require 'message)
@@ -132,9 +134,8 @@ If N is a negative number, add the N previous articles.
132If N is nil and any articles have been marked with the process mark, 134If N is nil and any articles have been marked with the process mark,
133move those articles instead." 135move those articles instead."
134 (interactive "P") 136 (interactive "P")
135 (gnus-set-global-variables)
136 (let* ((articles (gnus-summary-work-articles n)) 137 (let* ((articles (gnus-summary-work-articles n))
137 (tmp-buf (get-buffer-create "*soup work*")) 138 (tmp-buf (gnus-get-buffer-create "*soup work*"))
138 (area (gnus-soup-area gnus-newsgroup-name)) 139 (area (gnus-soup-area gnus-newsgroup-name))
139 (prefix (gnus-soup-area-prefix area)) 140 (prefix (gnus-soup-area-prefix area))
140 headers) 141 headers)
@@ -162,7 +163,8 @@ move those articles instead."
162 (gnus-summary-mark-as-read (car articles) gnus-souped-mark) 163 (gnus-summary-mark-as-read (car articles) gnus-souped-mark)
163 (setq articles (cdr articles))) 164 (setq articles (cdr articles)))
164 (kill-buffer tmp-buf)) 165 (kill-buffer tmp-buf))
165 (gnus-soup-save-areas))) 166 (gnus-soup-save-areas)
167 (gnus-set-mode-line 'summary)))
166 168
167(defun gnus-soup-pack-packet () 169(defun gnus-soup-pack-packet ()
168 "Make a SOUP packet from the SOUP areas." 170 "Make a SOUP packet from the SOUP areas."
@@ -205,7 +207,9 @@ for matching on group names.
205For instance, if you want to brew on all the nnml groups, as well as 207For instance, if you want to brew on all the nnml groups, as well as
206groups with \"emacs\" in the name, you could say something like: 208groups with \"emacs\" in the name, you could say something like:
207 209
208$ emacs -batch -f gnus-batch-brew-soup ^nnml \".*emacs.*\"" 210$ emacs -batch -f gnus-batch-brew-soup ^nnml \".*emacs.*\"
211
212Note -- this function hasn't been implemented yet."
209 (interactive) 213 (interactive)
210 nil) 214 nil)
211 215
@@ -311,6 +315,8 @@ If NOT-ALL, don't pack ticked articles."
311 (or (mail-header-lines header) "0")))) 315 (or (mail-header-lines header) "0"))))
312 316
313(defun gnus-soup-save-areas () 317(defun gnus-soup-save-areas ()
318 "Write all SOUP buffers."
319 (interactive)
314 (gnus-soup-write-areas) 320 (gnus-soup-write-areas)
315 (save-excursion 321 (save-excursion
316 (let (buf) 322 (let (buf)
@@ -367,22 +373,23 @@ The vector contain five strings,
367 [prefix name encoding description number] 373 [prefix name encoding description number]
368though the two last may be nil if they are missing." 374though the two last may be nil if they are missing."
369 (let (areas) 375 (let (areas)
370 (save-excursion 376 (when (file-exists-p file)
371 (set-buffer (nnheader-find-file-noselect file 'force)) 377 (save-excursion
372 (buffer-disable-undo (current-buffer)) 378 (set-buffer (nnheader-find-file-noselect file 'force))
373 (goto-char (point-min)) 379 (buffer-disable-undo (current-buffer))
374 (while (not (eobp)) 380 (goto-char (point-min))
375 (push (vector (gnus-soup-field) 381 (while (not (eobp))
376 (gnus-soup-field) 382 (push (vector (gnus-soup-field)
377 (gnus-soup-field) 383 (gnus-soup-field)
378 (and (eq (preceding-char) ?\t) 384 (gnus-soup-field)
379 (gnus-soup-field)) 385 (and (eq (preceding-char) ?\t)
380 (and (eq (preceding-char) ?\t) 386 (gnus-soup-field))
381 (string-to-int (gnus-soup-field)))) 387 (and (eq (preceding-char) ?\t)
382 areas) 388 (string-to-int (gnus-soup-field))))
383 (when (eq (preceding-char) ?\t) 389 areas)
384 (beginning-of-line 2))) 390 (when (eq (preceding-char) ?\t)
385 (kill-buffer (current-buffer))) 391 (beginning-of-line 2)))
392 (kill-buffer (current-buffer))))
386 areas)) 393 areas))
387 394
388(defun gnus-soup-parse-replies (file) 395(defun gnus-soup-parse-replies (file)
@@ -507,7 +514,7 @@ Return whether the unpacking was successful."
507 ".MSG")) 514 ".MSG"))
508 (msg-buf (and (file-exists-p msg-file) 515 (msg-buf (and (file-exists-p msg-file)
509 (nnheader-find-file-noselect msg-file))) 516 (nnheader-find-file-noselect msg-file)))
510 (tmp-buf (get-buffer-create " *soup send*")) 517 (tmp-buf (gnus-get-buffer-create " *soup send*"))
511 beg end) 518 beg end)
512 (cond 519 (cond
513 ((/= (gnus-soup-encoding-format 520 ((/= (gnus-soup-encoding-format
@@ -518,7 +525,6 @@ Return whether the unpacking was successful."
518 t) 525 t)
519 (t 526 (t
520 (buffer-disable-undo msg-buf) 527 (buffer-disable-undo msg-buf)
521 (buffer-disable-undo tmp-buf)
522 (set-buffer msg-buf) 528 (set-buffer msg-buf)
523 (goto-char (point-min)) 529 (goto-char (point-min))
524 (while (not (eobp)) 530 (while (not (eobp))
diff --git a/lisp/gnus/gnus-spec.el b/lisp/gnus/gnus-spec.el
index df440c97b3b..403b5169583 100644
--- a/lisp/gnus/gnus-spec.el
+++ b/lisp/gnus/gnus-spec.el
@@ -1,7 +1,7 @@
1;;; gnus-spec.el --- format spec functions for Gnus 1;;; gnus-spec.el --- format spec functions for Gnus
2;; Copyright (C) 1996,97 Free Software Foundation, Inc. 2;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: news 5;; Keywords: news
6 6
7;; This file is part of GNU Emacs. 7;; This file is part of GNU Emacs.
@@ -27,6 +27,8 @@
27 27
28(eval-when-compile (require 'cl)) 28(eval-when-compile (require 'cl))
29 29
30(eval-when-compile (require 'cl))
31
30(require 'gnus) 32(require 'gnus)
31 33
32;;; Internal variables. 34;;; Internal variables.
@@ -182,9 +184,8 @@
182 val) 184 val)
183 (when (and (boundp buffer) 185 (when (and (boundp buffer)
184 (setq val (symbol-value buffer)) 186 (setq val (symbol-value buffer))
185 (get-buffer val) 187 (gnus-buffer-exists-p val))
186 (buffer-name (get-buffer val))) 188 (set-buffer val))
187 (set-buffer (get-buffer val)))
188 (setq new-format (symbol-value 189 (setq new-format (symbol-value
189 (intern (format "gnus-%s-line-format" type))))) 190 (intern (format "gnus-%s-line-format" type)))))
190 (setq entry (cdr (assq type gnus-format-specs))) 191 (setq entry (cdr (assq type gnus-format-specs)))
@@ -238,9 +239,9 @@
238(defvar gnus-face-4 'bold) 239(defvar gnus-face-4 'bold)
239 240
240(defun gnus-face-face-function (form type) 241(defun gnus-face-face-function (form type)
241 `(gnus-put-text-property 242 `(gnus-add-text-properties
242 (point) (progn ,@form (point)) 243 (point) (progn ,@form (point))
243 'face ',(symbol-value (intern (format "gnus-face-%d" type))))) 244 '(gnus-face t face ,(symbol-value (intern (format "gnus-face-%d" type))))))
244 245
245(defun gnus-tilde-max-form (el max-width) 246(defun gnus-tilde-max-form (el max-width)
246 "Return a form that limits EL to MAX-WIDTH." 247 "Return a form that limits EL to MAX-WIDTH."
@@ -308,7 +309,8 @@
308 (let ((number (if (match-beginning 1) 309 (let ((number (if (match-beginning 1)
309 (match-string 1) "0")) 310 (match-string 1) "0"))
310 (delim (aref (match-string 2) 0))) 311 (delim (aref (match-string 2) 0)))
311 (if (or (= delim ?\() (= delim ?\{)) 312 (if (or (= delim ?\()
313 (= delim ?\{))
312 (replace-match (concat "\"(" (if (= delim ?\() "mouse" "face") 314 (replace-match (concat "\"(" (if (= delim ?\() "mouse" "face")
313 " " number " \"")) 315 " " number " \""))
314 (replace-match "\")\"")))) 316 (replace-match "\")\""))))
@@ -502,8 +504,7 @@ If PROPS, insert the result."
502(defun gnus-compile () 504(defun gnus-compile ()
503 "Byte-compile the user-defined format specs." 505 "Byte-compile the user-defined format specs."
504 (interactive) 506 (interactive)
505 (when gnus-xemacs 507 (require 'bytecomp)
506 (error "Can't compile specs under XEmacs"))
507 (let ((entries gnus-format-specs) 508 (let ((entries gnus-format-specs)
508 (byte-compile-warnings '(unresolved callargs redefine)) 509 (byte-compile-warnings '(unresolved callargs redefine))
509 entry gnus-tmp-func) 510 entry gnus-tmp-func)
@@ -514,17 +515,30 @@ If PROPS, insert the result."
514 (setq entry (pop entries)) 515 (setq entry (pop entries))
515 (if (eq (car entry) 'version) 516 (if (eq (car entry) 'version)
516 (setq gnus-format-specs (delq entry gnus-format-specs)) 517 (setq gnus-format-specs (delq entry gnus-format-specs))
517 (when (and (listp (caddr entry)) 518 (let ((form (caddr entry)))
518 (not (eq 'byte-code (caaddr entry)))) 519 (when (and (listp form)
519 (fset 'gnus-tmp-func `(lambda () ,(caddr entry))) 520 ;; Under GNU Emacs, it's (byte-code ...)
520 (byte-compile 'gnus-tmp-func) 521 (not (eq 'byte-code (car form)))
521 (setcar (cddr entry) (gnus-byte-code 'gnus-tmp-func))))) 522 ;; Under XEmacs, it's (funcall #<compiled-function ...>)
523 (not (and (eq 'funcall (car form))
524 (compiled-function-p (cadr form)))))
525 (fset 'gnus-tmp-func `(lambda () ,form))
526 (byte-compile 'gnus-tmp-func)
527 (setcar (cddr entry) (gnus-byte-code 'gnus-tmp-func))))))
522 528
523 (push (cons 'version emacs-version) gnus-format-specs) 529 (push (cons 'version emacs-version) gnus-format-specs)
524 ;; Mark the .newsrc.eld file as "dirty". 530 ;; Mark the .newsrc.eld file as "dirty".
525 (gnus-dribble-enter " ") 531 (gnus-dribble-touch)
526 (gnus-message 7 "Compiling user specs...done")))) 532 (gnus-message 7 "Compiling user specs...done"))))
527 533
534(defun gnus-set-format (type &optional insertable)
535 (set (intern (format "gnus-%s-line-format-spec" type))
536 (gnus-parse-format
537 (symbol-value (intern (format "gnus-%s-line-format" type)))
538 (symbol-value (intern (format "gnus-%s-line-format-alist" type)))
539 insertable)))
540
541
528(provide 'gnus-spec) 542(provide 'gnus-spec)
529 543
530;;; gnus-spec.el ends here 544;;; gnus-spec.el ends here
diff --git a/lisp/gnus/gnus-srvr.el b/lisp/gnus/gnus-srvr.el
index 05fb4ae18a0..dc3dd1a6fdb 100644
--- a/lisp/gnus/gnus-srvr.el
+++ b/lisp/gnus/gnus-srvr.el
@@ -1,7 +1,7 @@
1;;; gnus-srvr.el --- virtual server support for Gnus 1;;; gnus-srvr.el --- virtual server support for Gnus
2;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. 2;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: news 5;; Keywords: news
6 6
7;; This file is part of GNU Emacs. 7;; This file is part of GNU Emacs.
@@ -27,6 +27,8 @@
27 27
28(eval-when-compile (require 'cl)) 28(eval-when-compile (require 'cl))
29 29
30(eval-when-compile (require 'cl))
31
30(require 'gnus) 32(require 'gnus)
31(require 'gnus-spec) 33(require 'gnus-spec)
32(require 'gnus-group) 34(require 'gnus-group)
@@ -39,9 +41,16 @@
39(defconst gnus-server-line-format " {%(%h:%w%)} %s\n" 41(defconst gnus-server-line-format " {%(%h:%w%)} %s\n"
40 "Format of server lines. 42 "Format of server lines.
41It works along the same lines as a normal formatting string, 43It works along the same lines as a normal formatting string,
42with some simple extensions.") 44with some simple extensions.
45
46The following specs are understood:
47
48%h backend
49%n name
50%w address
51%s status")
43 52
44(defvar gnus-server-mode-line-format "Gnus List of servers" 53(defvar gnus-server-mode-line-format "Gnus: %%b"
45 "The format specification for the server mode line.") 54 "The format specification for the server mode line.")
46 55
47(defvar gnus-server-exit-hook nil 56(defvar gnus-server-exit-hook nil
@@ -52,15 +61,15 @@ with some simple extensions.")
52(defvar gnus-inserted-opened-servers nil) 61(defvar gnus-inserted-opened-servers nil)
53 62
54(defvar gnus-server-line-format-alist 63(defvar gnus-server-line-format-alist
55 `((?h how ?s) 64 `((?h gnus-tmp-how ?s)
56 (?n name ?s) 65 (?n gnus-tmp-name ?s)
57 (?w where ?s) 66 (?w gnus-tmp-where ?s)
58 (?s status ?s))) 67 (?s gnus-tmp-status ?s)))
59 68
60(defvar gnus-server-mode-line-format-alist 69(defvar gnus-server-mode-line-format-alist
61 `((?S news-server ?s) 70 `((?S gnus-tmp-news-server ?s)
62 (?M news-method ?s) 71 (?M gnus-tmp-news-method ?s)
63 (?u user-defined ?s))) 72 (?u gnus-tmp-user-defined ?s)))
64 73
65(defvar gnus-server-line-format-spec nil) 74(defvar gnus-server-line-format-spec nil)
66(defvar gnus-server-mode-line-format-spec nil) 75(defvar gnus-server-mode-line-format-spec nil)
@@ -99,7 +108,7 @@ with some simple extensions.")
99 ["Close All" gnus-server-close-all-servers t] 108 ["Close All" gnus-server-close-all-servers t]
100 ["Reset All" gnus-server-remove-denials t])) 109 ["Reset All" gnus-server-remove-denials t]))
101 110
102 (run-hooks 'gnus-server-menu-hook))) 111 (gnus-run-hooks 'gnus-server-menu-hook)))
103 112
104(defvar gnus-server-mode-map nil) 113(defvar gnus-server-mode-map nil)
105(put 'gnus-server-mode 'mode-class 'special) 114(put 'gnus-server-mode 'mode-class 'special)
@@ -108,28 +117,27 @@ with some simple extensions.")
108 (setq gnus-server-mode-map (make-sparse-keymap)) 117 (setq gnus-server-mode-map (make-sparse-keymap))
109 (suppress-keymap gnus-server-mode-map) 118 (suppress-keymap gnus-server-mode-map)
110 119
111 (gnus-define-keys 120 (gnus-define-keys gnus-server-mode-map
112 gnus-server-mode-map 121 " " gnus-server-read-server
113 " " gnus-server-read-server 122 "\r" gnus-server-read-server
114 "\r" gnus-server-read-server 123 gnus-mouse-2 gnus-server-pick-server
115 gnus-mouse-2 gnus-server-pick-server 124 "q" gnus-server-exit
116 "q" gnus-server-exit 125 "l" gnus-server-list-servers
117 "l" gnus-server-list-servers 126 "k" gnus-server-kill-server
118 "k" gnus-server-kill-server 127 "y" gnus-server-yank-server
119 "y" gnus-server-yank-server 128 "c" gnus-server-copy-server
120 "c" gnus-server-copy-server 129 "a" gnus-server-add-server
121 "a" gnus-server-add-server 130 "e" gnus-server-edit-server
122 "e" gnus-server-edit-server 131 "s" gnus-server-scan-server
123 "s" gnus-server-scan-server 132
124 133 "O" gnus-server-open-server
125 "O" gnus-server-open-server 134 "\M-o" gnus-server-open-all-servers
126 "\M-o" gnus-server-open-all-servers 135 "C" gnus-server-close-server
127 "C" gnus-server-close-server 136 "\M-c" gnus-server-close-all-servers
128 "\M-c" gnus-server-close-all-servers 137 "D" gnus-server-deny-server
129 "D" gnus-server-deny-server 138 "R" gnus-server-remove-denials
130 "R" gnus-server-remove-denials 139
131 140 "g" gnus-server-regenerate-server
132 "g" gnus-server-regenerate-server
133 141
134 "\C-c\C-i" gnus-info-find-node 142 "\C-c\C-i" gnus-info-find-node
135 "\C-c\C-b" gnus-bug)) 143 "\C-c\C-b" gnus-bug))
@@ -158,13 +166,13 @@ The following commands are available:
158 (buffer-disable-undo (current-buffer)) 166 (buffer-disable-undo (current-buffer))
159 (setq truncate-lines t) 167 (setq truncate-lines t)
160 (setq buffer-read-only t) 168 (setq buffer-read-only t)
161 (run-hooks 'gnus-server-mode-hook)) 169 (gnus-run-hooks 'gnus-server-mode-hook))
162 170
163(defun gnus-server-insert-server-line (name method) 171(defun gnus-server-insert-server-line (gnus-tmp-name method)
164 (let* ((how (car method)) 172 (let* ((gnus-tmp-how (car method))
165 (where (nth 1 method)) 173 (gnus-tmp-where (nth 1 method))
166 (elem (assoc method gnus-opened-servers)) 174 (elem (assoc method gnus-opened-servers))
167 (status (cond ((eq (nth 1 elem) 'denied) 175 (gnus-tmp-status (cond ((eq (nth 1 elem) 'denied)
168 "(denied)") 176 "(denied)")
169 ((or (gnus-server-opened method) 177 ((or (gnus-server-opened method)
170 (eq (nth 1 elem) 'ok)) 178 (eq (nth 1 elem) 'ok))
@@ -177,7 +185,7 @@ The following commands are available:
177 (prog1 (1+ (point)) 185 (prog1 (1+ (point))
178 ;; Insert the text. 186 ;; Insert the text.
179 (eval gnus-server-line-format-spec)) 187 (eval gnus-server-line-format-spec))
180 (list 'gnus-server (intern name))))) 188 (list 'gnus-server (intern gnus-tmp-name)))))
181 189
182(defun gnus-enter-server-buffer () 190(defun gnus-enter-server-buffer ()
183 "Set up the server buffer." 191 "Set up the server buffer."
@@ -189,18 +197,14 @@ The following commands are available:
189 "Initialize the server buffer." 197 "Initialize the server buffer."
190 (unless (get-buffer gnus-server-buffer) 198 (unless (get-buffer gnus-server-buffer)
191 (save-excursion 199 (save-excursion
192 (set-buffer (get-buffer-create gnus-server-buffer)) 200 (set-buffer (gnus-get-buffer-create gnus-server-buffer))
193 (gnus-server-mode) 201 (gnus-server-mode)
194 (when gnus-carpal 202 (when gnus-carpal
195 (gnus-carpal-setup-buffer 'server))))) 203 (gnus-carpal-setup-buffer 'server)))))
196 204
197(defun gnus-server-prepare () 205(defun gnus-server-prepare ()
198 (setq gnus-server-mode-line-format-spec 206 (gnus-set-format 'server-mode)
199 (gnus-parse-format gnus-server-mode-line-format 207 (gnus-set-format 'server t)
200 gnus-server-mode-line-format-alist))
201 (setq gnus-server-line-format-spec
202 (gnus-parse-format gnus-server-line-format
203 gnus-server-line-format-alist t))
204 (let ((alist gnus-server-alist) 208 (let ((alist gnus-server-alist)
205 (buffer-read-only nil) 209 (buffer-read-only nil)
206 (opened gnus-opened-servers) 210 (opened gnus-opened-servers)
@@ -219,7 +223,9 @@ The following commands are available:
219 ;; Then we insert the list of servers that have been opened in 223 ;; Then we insert the list of servers that have been opened in
220 ;; this session. 224 ;; this session.
221 (while opened 225 (while opened
222 (unless (member (caar opened) done) 226 (when (and (not (member (caar opened) done))
227 ;; Just ignore ephemeral servers.
228 (not (member (caar opened) gnus-ephemeral-servers)))
223 (push (caar opened) done) 229 (push (caar opened) done)
224 (gnus-server-insert-server-line 230 (gnus-server-insert-server-line
225 (setq op-ser (format "%s:%s" (caaar opened) (nth 1 (caar opened)))) 231 (setq op-ser (format "%s:%s" (caaar opened) (nth 1 (caar opened))))
@@ -283,7 +289,7 @@ The following commands are available:
283 (error "No server on the current line"))) 289 (error "No server on the current line")))
284 (unless (assoc server gnus-server-alist) 290 (unless (assoc server gnus-server-alist)
285 (error "Read-only server %s" server)) 291 (error "Read-only server %s" server))
286 (gnus-dribble-enter "") 292 (gnus-dribble-touch)
287 (let ((buffer-read-only nil)) 293 (let ((buffer-read-only nil))
288 (gnus-delete-line)) 294 (gnus-delete-line))
289 (push (assoc server gnus-server-alist) gnus-server-killed-servers) 295 (push (assoc server gnus-server-alist) gnus-server-killed-servers)
@@ -316,7 +322,7 @@ The following commands are available:
316(defun gnus-server-exit () 322(defun gnus-server-exit ()
317 "Return to the group buffer." 323 "Return to the group buffer."
318 (interactive) 324 (interactive)
319 (run-hooks 'gnus-server-exit-hook) 325 (gnus-run-hooks 'gnus-server-exit-hook)
320 (kill-buffer (current-buffer)) 326 (kill-buffer (current-buffer))
321 (gnus-configure-windows 'group t)) 327 (gnus-configure-windows 'group t))
322 328
@@ -462,16 +468,19 @@ The following commands are available:
462(defun gnus-server-scan-server (server) 468(defun gnus-server-scan-server (server)
463 "Request a scan from the current server." 469 "Request a scan from the current server."
464 (interactive (list (gnus-server-server-name))) 470 (interactive (list (gnus-server-server-name)))
465 (gnus-message 3 "Scanning %s...done" server) 471 (let ((method (gnus-server-to-method server)))
466 (gnus-request-scan nil (gnus-server-to-method server)) 472 (if (not (gnus-get-function method 'request-scan))
467 (gnus-message 3 "Scanning %s...done" server)) 473 (error "Server %s can't scan" (car method))
474 (gnus-message 3 "Scanning %s..." server)
475 (gnus-request-scan nil method)
476 (gnus-message 3 "Scanning %s...done" server))))
468 477
469(defun gnus-server-read-server (server) 478(defun gnus-server-read-server (server)
470 "Browse a server." 479 "Browse a server."
471 (interactive (list (gnus-server-server-name))) 480 (interactive (list (gnus-server-server-name)))
472 (let ((buf (current-buffer))) 481 (let ((buf (current-buffer)))
473 (prog1 482 (prog1
474 (gnus-browse-foreign-server (gnus-server-to-method server) buf) 483 (gnus-browse-foreign-server server buf)
475 (save-excursion 484 (save-excursion
476 (set-buffer buf) 485 (set-buffer buf)
477 (gnus-server-update-server (gnus-server-server-name)) 486 (gnus-server-update-server (gnus-server-server-name))
@@ -530,25 +539,24 @@ The following commands are available:
530 '("Browse" 539 '("Browse"
531 ["Subscribe" gnus-browse-unsubscribe-current-group t] 540 ["Subscribe" gnus-browse-unsubscribe-current-group t]
532 ["Read" gnus-browse-read-group t] 541 ["Read" gnus-browse-read-group t]
533 ["Select" gnus-browse-read-group t] 542 ["Select" gnus-browse-select-group t]
534 ["Next" gnus-browse-next-group t] 543 ["Next" gnus-browse-next-group t]
535 ["Prev" gnus-browse-next-group t] 544 ["Prev" gnus-browse-next-group t]
536 ["Exit" gnus-browse-exit t])) 545 ["Exit" gnus-browse-exit t]))
537 (run-hooks 'gnus-browse-menu-hook))) 546 (gnus-run-hooks 'gnus-browse-menu-hook)))
538 547
539(defvar gnus-browse-current-method nil) 548(defvar gnus-browse-current-method nil)
540(defvar gnus-browse-return-buffer nil) 549(defvar gnus-browse-return-buffer nil)
541 550
542(defvar gnus-browse-buffer "*Gnus Browse Server*") 551(defvar gnus-browse-buffer "*Gnus Browse Server*")
543 552
544(defun gnus-browse-foreign-server (method &optional return-buffer) 553(defun gnus-browse-foreign-server (server &optional return-buffer)
545 "Browse the server METHOD." 554 "Browse the server SERVER."
546 (setq gnus-browse-current-method method) 555 (setq gnus-browse-current-method server)
547 (setq gnus-browse-return-buffer return-buffer) 556 (setq gnus-browse-return-buffer return-buffer)
548 (when (stringp method) 557 (let* ((method (gnus-server-to-method server))
549 (setq method (gnus-server-to-method method))) 558 (gnus-select-method method)
550 (let ((gnus-select-method method) 559 groups group)
551 groups group)
552 (gnus-message 5 "Connecting to %s..." (nth 1 method)) 560 (gnus-message 5 "Connecting to %s..." (nth 1 method))
553 (cond 561 (cond
554 ((not (gnus-check-server method)) 562 ((not (gnus-check-server method))
@@ -565,8 +573,7 @@ The following commands are available:
565 1 "Couldn't request list: %s" (gnus-status-message method)) 573 1 "Couldn't request list: %s" (gnus-status-message method))
566 nil) 574 nil)
567 (t 575 (t
568 (get-buffer-create gnus-browse-buffer) 576 (gnus-get-buffer-create gnus-browse-buffer)
569 (gnus-add-current-to-buffer-list)
570 (when gnus-carpal 577 (when gnus-carpal
571 (gnus-carpal-setup-buffer 'browse)) 578 (gnus-carpal-setup-buffer 'browse))
572 (gnus-configure-windows 'browse) 579 (gnus-configure-windows 'browse)
@@ -587,9 +594,11 @@ The following commands are available:
587 (while (re-search-forward 594 (while (re-search-forward
588 "\\(^[^ \t]+\\)[ \t]+[0-9]+[ \t]+[0-9]+" nil t) 595 "\\(^[^ \t]+\\)[ \t]+[0-9]+[ \t]+[0-9]+" nil t)
589 (goto-char (match-end 1)) 596 (goto-char (match-end 1))
590 (push (cons (match-string 1) 597 (condition-case ()
591 (max 0 (- (1+ (read cur)) (read cur)))) 598 (push (cons (match-string 1)
592 groups)))) 599 (max 0 (- (1+ (read cur)) (read cur))))
600 groups)
601 (error nil)))))
593 (setq groups (sort groups 602 (setq groups (sort groups
594 (lambda (l1 l2) 603 (lambda (l1 l2)
595 (string< (car l1) (car l2))))) 604 (string< (car l1) (car l2)))))
@@ -633,17 +642,21 @@ buffer.
633 (setq truncate-lines t) 642 (setq truncate-lines t)
634 (gnus-set-default-directory) 643 (gnus-set-default-directory)
635 (setq buffer-read-only t) 644 (setq buffer-read-only t)
636 (run-hooks 'gnus-browse-mode-hook)) 645 (gnus-run-hooks 'gnus-browse-mode-hook))
637 646
638(defun gnus-browse-read-group (&optional no-article) 647(defun gnus-browse-read-group (&optional no-article)
639 "Enter the group at the current line." 648 "Enter the group at the current line."
640 (interactive) 649 (interactive)
641 (let ((group (gnus-group-real-name (gnus-browse-group-name)))) 650 (let ((group (gnus-browse-group-name)))
642 (unless (gnus-group-read-ephemeral-group 651 (if (or (not (gnus-get-info group))
643 group gnus-browse-current-method nil 652 (gnus-ephemeral-group-p group))
644 (cons (current-buffer) 'browse)) 653 (unless (gnus-group-read-ephemeral-group
645 (error "Couldn't enter %s" group)))) 654 group gnus-browse-current-method nil
646 655 (cons (current-buffer) 'browse))
656 (error "Couldn't enter %s" group))
657 (unless (gnus-group-read-group nil no-article group)
658 (error "Couldn't enter %s" group)))))
659
647(defun gnus-browse-select-group () 660(defun gnus-browse-select-group ()
648 "Select the current group." 661 "Select the current group."
649 (interactive) 662 (interactive)
@@ -697,18 +710,22 @@ buffer.
697 ;; If this group it killed, then we want to subscribe it. 710 ;; If this group it killed, then we want to subscribe it.
698 (when (= (following-char) ?K) 711 (when (= (following-char) ?K)
699 (setq sub t)) 712 (setq sub t))
700 (when (gnus-gethash (setq group (gnus-browse-group-name)) 713 (setq group (gnus-browse-group-name))
701 gnus-newsrc-hashtb) 714 (when (and sub
715 (cadr (gnus-gethash group gnus-newsrc-hashtb)))
702 (error "Group already subscribed")) 716 (error "Group already subscribed"))
703 ;; Make sure the group has been properly removed before we
704 ;; subscribe to it.
705 (gnus-kill-ephemeral-group group)
706 (delete-char 1) 717 (delete-char 1)
707 (if sub 718 (if sub
708 (progn 719 (progn
720 ;; Make sure the group has been properly removed before we
721 ;; subscribe to it.
722 (gnus-kill-ephemeral-group group)
709 (gnus-group-change-level 723 (gnus-group-change-level
710 (list t group gnus-level-default-subscribed 724 (list t group gnus-level-default-subscribed
711 nil nil gnus-browse-current-method) 725 nil nil (if (gnus-server-equal
726 gnus-browse-current-method "native")
727 nil
728 gnus-browse-current-method))
712 gnus-level-default-subscribed gnus-level-killed 729 gnus-level-default-subscribed gnus-level-killed
713 (and (car (nth 1 gnus-newsrc-alist)) 730 (and (car (nth 1 gnus-newsrc-alist))
714 (gnus-gethash (car (nth 1 gnus-newsrc-alist)) 731 (gnus-gethash (car (nth 1 gnus-newsrc-alist))
diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el
index f2f41ad9bbd..01c75bbf395 100644
--- a/lisp/gnus/gnus-start.el
+++ b/lisp/gnus/gnus-start.el
@@ -1,7 +1,7 @@
1;;; gnus-start.el --- startup functions for Gnus 1;;; gnus-start.el --- startup functions for Gnus
2;; Copyright (C) 1996,97 Free Software Foundation, Inc. 2;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: news 5;; Keywords: news
6 6
7;; This file is part of GNU Emacs. 7;; This file is part of GNU Emacs.
@@ -52,7 +52,7 @@ If a file with the `.el' or `.elc' suffixes exists, it will be read instead."
52 (directory-file-name installation-directory)) 52 (directory-file-name installation-directory))
53 "site-lisp/gnus-init") 53 "site-lisp/gnus-init")
54 (error nil)) 54 (error nil))
55 "The site-wide Gnus Emacs-Lisp startup file name, or nil if none. 55 "*The site-wide Gnus Emacs-Lisp startup file name, or nil if none.
56If a file with the `.el' or `.elc' suffixes exists, it will be read instead." 56If a file with the `.el' or `.elc' suffixes exists, it will be read instead."
57 :group 'gnus-start 57 :group 'gnus-start
58 :type '(choice file (const nil))) 58 :type '(choice file (const nil)))
@@ -80,18 +80,18 @@ saved will be used."
80 :type '(choice directory (const nil))) 80 :type '(choice directory (const nil)))
81 81
82(defcustom gnus-check-new-newsgroups 'ask-server 82(defcustom gnus-check-new-newsgroups 'ask-server
83 "*Non-nil means that Gnus will run gnus-find-new-newsgroups at startup. 83 "*Non-nil means that Gnus will run `gnus-find-new-newsgroups' at startup.
84This normally finds new newsgroups by comparing the active groups the 84This normally finds new newsgroups by comparing the active groups the
85servers have already reported with those Gnus already knows, either alive 85servers have already reported with those Gnus already knows, either alive
86or killed. 86or killed.
87 87
88When any of the following are true, gnus-find-new-newsgroups will instead 88When any of the following are true, `gnus-find-new-newsgroups' will instead
89ask the servers (primary, secondary, and archive servers) to list new 89ask the servers (primary, secondary, and archive servers) to list new
90groups since the last time it checked: 90groups since the last time it checked:
91 1. This variable is `ask-server'. 91 1. This variable is `ask-server'.
92 2. This variable is a list of select methods (see below). 92 2. This variable is a list of select methods (see below).
93 3. `gnus-read-active-file' is nil or `some'. 93 3. `gnus-read-active-file' is nil or `some'.
94 4. A prefix argument is given to gnus-find-new-newsgroups interactively. 94 4. A prefix argument is given to `gnus-find-new-newsgroups' interactively.
95 95
96Thus, if this variable is `ask-server' or a list of select methods or 96Thus, if this variable is `ask-server' or a list of select methods or
97`gnus-read-active-file' is nil or `some', then the killed list is no 97`gnus-read-active-file' is nil or `some', then the killed list is no
@@ -194,7 +194,8 @@ might take a while. By setting this variable to nil, you'll save time,
194but you won't be told how many unread articles there are in the 194but you won't be told how many unread articles there are in the
195groups." 195groups."
196 :group 'gnus-group-levels 196 :group 'gnus-group-levels
197 :type 'integer) 197 :type '(choice integer
198 (const :tag "none" nil)))
198 199
199(defcustom gnus-save-newsrc-file t 200(defcustom gnus-save-newsrc-file t
200 "*Non-nil means that Gnus will save the `.newsrc' file. 201 "*Non-nil means that Gnus will save the `.newsrc' file.
@@ -228,7 +229,7 @@ not match this regexp will be removed before saving the list."
228 "[][\"#'()]" ; bogus characters 229 "[][\"#'()]" ; bogus characters
229 ) 230 )
230 "\\|")) 231 "\\|"))
231 "A regexp to match uninteresting newsgroups in the active file. 232 "*A regexp to match uninteresting newsgroups in the active file.
232Any lines in the active file matching this regular expression are 233Any lines in the active file matching this regular expression are
233removed from the newsgroup list before anything else is done to it, 234removed from the newsgroup list before anything else is done to it,
234thus making them effectively non-existent." 235thus making them effectively non-existent."
@@ -253,8 +254,6 @@ for your decision; `gnus-subscribe-killed' kills all new groups;
253 (function-item gnus-subscribe-zombies) 254 (function-item gnus-subscribe-zombies)
254 function)) 255 function))
255 256
256;; Suggested by a bug report by Hallvard B Furuseth.
257;; <h.b.furuseth@usit.uio.no>.
258(defcustom gnus-subscribe-options-newsgroup-method 257(defcustom gnus-subscribe-options-newsgroup-method
259 'gnus-subscribe-alphabetically 258 'gnus-subscribe-alphabetically
260 "*This function is called to subscribe newsgroups mentioned on \"options -n\" lines. 259 "*This function is called to subscribe newsgroups mentioned on \"options -n\" lines.
@@ -288,7 +287,7 @@ hierarchy in its entirety."
288 :type 'boolean) 287 :type 'boolean)
289 288
290(defcustom gnus-auto-subscribed-groups 289(defcustom gnus-auto-subscribed-groups
291 "^nnml\\|^nnfolder\\|^nnmbox\\|^nnmh\\|^nnbabyl" 290 "nnml\\|^nnfolder\\|^nnmbox\\|^nnmh\\|^nnbabyl"
292 "*All new groups that match this regexp will be subscribed automatically. 291 "*All new groups that match this regexp will be subscribed automatically.
293Note that this variable only deals with new groups. It has no effect 292Note that this variable only deals with new groups. It has no effect
294whatsoever on old groups. 293whatsoever on old groups.
@@ -337,11 +336,22 @@ This hook is called after Gnus is connected to the NNTP server."
337 :group 'gnus-start 336 :group 'gnus-start
338 :type 'hook) 337 :type 'hook)
339 338
339(defcustom gnus-before-startup-hook nil
340 "A hook called at before startup.
341This hook is called as the first thing when Gnus is started."
342 :group 'gnus-start
343 :type 'hook)
344
340(defcustom gnus-started-hook nil 345(defcustom gnus-started-hook nil
341 "A hook called as the last thing after startup." 346 "A hook called as the last thing after startup."
342 :group 'gnus-start 347 :group 'gnus-start
343 :type 'hook) 348 :type 'hook)
344 349
350(defcustom gnus-setup-news-hook nil
351 "A hook after reading the .newsrc file, but before generating the buffer."
352 :group 'gnus-start
353 :type 'hook)
354
345(defcustom gnus-get-new-news-hook nil 355(defcustom gnus-get-new-news-hook nil
346 "A hook run just before Gnus checks for new news." 356 "A hook run just before Gnus checks for new news."
347 :group 'gnus-group-new 357 :group 'gnus-group-new
@@ -350,7 +360,7 @@ This hook is called after Gnus is connected to the NNTP server."
350(defcustom gnus-after-getting-new-news-hook 360(defcustom gnus-after-getting-new-news-hook
351 (when (gnus-boundp 'display-time-timer) 361 (when (gnus-boundp 'display-time-timer)
352 '(display-time-event-handler)) 362 '(display-time-event-handler))
353 "A hook run after Gnus checks for new news." 363 "*A hook run after Gnus checks for new news."
354 :group 'gnus-group-new 364 :group 'gnus-group-new
355 :type 'hook) 365 :type 'hook)
356 366
@@ -371,6 +381,14 @@ Can be used to turn version control on or off."
371 :group 'gnus-newsrc 381 :group 'gnus-newsrc
372 :type 'hook) 382 :type 'hook)
373 383
384(defcustom gnus-always-read-dribble-file nil
385 "Uncoditionally read the dribble file."
386 :group 'gnus-newsrc
387 :type 'boolean)
388
389(defvar gnus-startup-file-coding-system 'binary
390 "*Coding system for startup file.")
391
374(defvar gnus-startup-file-coding-system 'binary 392(defvar gnus-startup-file-coding-system 'binary
375 "*Coding system for startup file.") 393 "*Coding system for startup file.")
376 394
@@ -439,7 +457,8 @@ Can be used to turn version control on or off."
439 (push prefix prefixes) 457 (push prefix prefixes)
440 (message "Descend hierarchy %s? ([y]nsq): " 458 (message "Descend hierarchy %s? ([y]nsq): "
441 (substring prefix 1 (1- (length prefix)))) 459 (substring prefix 1 (1- (length prefix))))
442 (while (not (memq (setq ans (read-char)) '(?y ?\n ?\r ?n ?s ?q))) 460 (while (not (memq (setq ans (read-char-exclusive))
461 '(?y ?\n ?\r ?n ?s ?q)))
443 (ding) 462 (ding)
444 (message "Descend hierarchy %s? ([y]nsq): " 463 (message "Descend hierarchy %s? ([y]nsq): "
445 (substring prefix 1 (1- (length prefix))))) 464 (substring prefix 1 (1- (length prefix)))))
@@ -467,7 +486,8 @@ Can be used to turn version control on or off."
467 (setq groups (cdr groups)))) 486 (setq groups (cdr groups))))
468 (t nil))) 487 (t nil)))
469 (message "Subscribe %s? ([n]yq)" (car groups)) 488 (message "Subscribe %s? ([n]yq)" (car groups))
470 (while (not (memq (setq ans (read-char)) '(?y ?\n ?\r ?q ?n))) 489 (while (not (memq (setq ans (read-char-exclusive))
490 '(?y ?\n ?\r ?q ?n)))
471 (ding) 491 (ding)
472 (message "Subscribe %s? ([n]yq)" (car groups))) 492 (message "Subscribe %s? ([n]yq)" (car groups)))
473 (setq group (car groups)) 493 (setq group (car groups))
@@ -567,6 +587,7 @@ the first newsgroup."
567(defvar gnus-newsgroup-unreads) 587(defvar gnus-newsgroup-unreads)
568(defvar nnoo-state-alist) 588(defvar nnoo-state-alist)
569(defvar gnus-current-select-method) 589(defvar gnus-current-select-method)
590
570(defun gnus-clear-system () 591(defun gnus-clear-system ()
571 "Clear all variables and buffers." 592 "Clear all variables and buffers."
572 ;; Clear Gnus variables. 593 ;; Clear Gnus variables.
@@ -596,7 +617,8 @@ the first newsgroup."
596 gnus-newsgroup-data nil 617 gnus-newsgroup-data nil
597 gnus-newsgroup-unreads nil 618 gnus-newsgroup-unreads nil
598 nnoo-state-alist nil 619 nnoo-state-alist nil
599 gnus-current-select-method nil) 620 gnus-current-select-method nil
621 gnus-ephemeral-servers nil)
600 (gnus-shutdown 'gnus) 622 (gnus-shutdown 'gnus)
601 ;; Kill the startup file. 623 ;; Kill the startup file.
602 (and gnus-current-startup-file 624 (and gnus-current-startup-file
@@ -609,8 +631,9 @@ the first newsgroup."
609 (kill-buffer (get-file-buffer (gnus-newsgroup-kill-file nil)))) 631 (kill-buffer (get-file-buffer (gnus-newsgroup-kill-file nil))))
610 (gnus-kill-buffer nntp-server-buffer) 632 (gnus-kill-buffer nntp-server-buffer)
611 ;; Kill Gnus buffers. 633 ;; Kill Gnus buffers.
612 (while gnus-buffer-list 634 (let ((buffers (gnus-buffers)))
613 (gnus-kill-buffer (pop gnus-buffer-list))) 635 (when buffers
636 (mapcar 'kill-buffer buffers)))
614 ;; Remove Gnus frames. 637 ;; Remove Gnus frames.
615 (gnus-kill-gnus-frames)) 638 (gnus-kill-gnus-frames))
616 639
@@ -634,10 +657,7 @@ startup level. If ARG is non-nil and not a positive number, Gnus will
634prompt the user for the name of an NNTP server to use." 657prompt the user for the name of an NNTP server to use."
635 (interactive "P") 658 (interactive "P")
636 659
637 (if (and (get-buffer gnus-group-buffer) 660 (if (gnus-alive-p)
638 (save-excursion
639 (set-buffer gnus-group-buffer)
640 (eq major-mode 'gnus-group-mode)))
641 (progn 661 (progn
642 (switch-to-buffer gnus-group-buffer) 662 (switch-to-buffer gnus-group-buffer)
643 (gnus-group-get-new-news 663 (gnus-group-get-new-news
@@ -645,16 +665,21 @@ prompt the user for the name of an NNTP server to use."
645 (> arg 0) 665 (> arg 0)
646 (max (car gnus-group-list-mode) arg)))) 666 (max (car gnus-group-list-mode) arg))))
647 667
648 (gnus-splash)
649 (gnus-clear-system) 668 (gnus-clear-system)
669 (gnus-splash)
670 (gnus-run-hooks 'gnus-before-startup-hook)
650 (nnheader-init-server-buffer) 671 (nnheader-init-server-buffer)
651 (setq gnus-slave slave) 672 (setq gnus-slave slave)
652 (gnus-read-init-file) 673 (gnus-read-init-file)
653 674
654 (when (and (string-match "XEmacs" (emacs-version)) 675 (when gnus-simple-splash
655 gnus-simple-splash)
656 (setq gnus-simple-splash nil) 676 (setq gnus-simple-splash nil)
657 (gnus-xmas-splash)) 677 (cond
678 (gnus-xemacs
679 (gnus-xmas-splash))
680 ((and (eq window-system 'x)
681 (= (frame-height) (1+ (window-height))))
682 (gnus-x-splash))))
658 683
659 (let ((level (and (numberp arg) (> arg 0) arg)) 684 (let ((level (and (numberp arg) (> arg 0) arg))
660 did-connect) 685 did-connect)
@@ -666,7 +691,7 @@ prompt the user for the name of an NNTP server to use."
666 (if (and (not dont-connect) 691 (if (and (not dont-connect)
667 (not did-connect)) 692 (not did-connect))
668 (gnus-group-quit) 693 (gnus-group-quit)
669 (run-hooks 'gnus-startup-hook) 694 (gnus-run-hooks 'gnus-startup-hook)
670 ;; NNTP server is successfully open. 695 ;; NNTP server is successfully open.
671 696
672 ;; Find the current startup file name. 697 ;; Find the current startup file name.
@@ -684,12 +709,23 @@ prompt the user for the name of an NNTP server to use."
684 709
685 ;; Do the actual startup. 710 ;; Do the actual startup.
686 (gnus-setup-news nil level dont-connect) 711 (gnus-setup-news nil level dont-connect)
712 (gnus-run-hooks 'gnus-setup-news-hook)
713 (gnus-start-draft-setup)
687 ;; Generate the group buffer. 714 ;; Generate the group buffer.
688 (gnus-group-list-groups level) 715 (gnus-group-list-groups level)
689 (gnus-group-first-unread-group) 716 (gnus-group-first-unread-group)
690 (gnus-configure-windows 'group) 717 (gnus-configure-windows 'group)
691 (gnus-group-set-mode-line) 718 (gnus-group-set-mode-line)
692 (run-hooks 'gnus-started-hook)))))) 719 (gnus-run-hooks 'gnus-started-hook))))))
720
721(defun gnus-start-draft-setup ()
722 "Make sure the draft group exists."
723 (gnus-request-create-group "drafts" '(nndraft ""))
724 (unless (gnus-gethash "nndraft:drafts" gnus-newsrc-hashtb)
725 (let ((gnus-level-default-subscribed 1))
726 (gnus-subscribe-group "nndraft:drafts" nil '(nndraft "")))
727 (gnus-group-set-parameter
728 "nndraft:drafts" 'gnus-dummy '((gnus-draft-mode)))))
693 729
694;;;###autoload 730;;;###autoload
695(defun gnus-unload () 731(defun gnus-unload ()
@@ -733,6 +769,9 @@ prompt the user for the name of an NNTP server to use."
733 (insert string "\n") 769 (insert string "\n")
734 (set-window-point (get-buffer-window (current-buffer)) (point-max)) 770 (set-window-point (get-buffer-window (current-buffer)) (point-max))
735 (bury-buffer gnus-dribble-buffer) 771 (bury-buffer gnus-dribble-buffer)
772 (save-excursion
773 (set-buffer gnus-group-buffer)
774 (gnus-group-set-mode-line))
736 (set-buffer obuf)))) 775 (set-buffer obuf))))
737 776
738(defun gnus-dribble-touch () 777(defun gnus-dribble-touch ()
@@ -744,9 +783,8 @@ prompt the user for the name of an NNTP server to use."
744 (let ((dribble-file (gnus-dribble-file-name))) 783 (let ((dribble-file (gnus-dribble-file-name)))
745 (save-excursion 784 (save-excursion
746 (set-buffer (setq gnus-dribble-buffer 785 (set-buffer (setq gnus-dribble-buffer
747 (get-buffer-create 786 (gnus-get-buffer-create
748 (file-name-nondirectory dribble-file)))) 787 (file-name-nondirectory dribble-file))))
749 (gnus-add-current-to-buffer-list)
750 (erase-buffer) 788 (erase-buffer)
751 (setq buffer-file-name dribble-file) 789 (setq buffer-file-name dribble-file)
752 (auto-save-mode t) 790 (auto-save-mode t)
@@ -771,8 +809,9 @@ prompt the user for the name of an NNTP server to use."
771 (setq modes (file-modes gnus-current-startup-file))) 809 (setq modes (file-modes gnus-current-startup-file)))
772 (set-file-modes dribble-file modes)) 810 (set-file-modes dribble-file modes))
773 ;; Possibly eval the file later. 811 ;; Possibly eval the file later.
774 (when (gnus-y-or-n-p 812 (when (or gnus-always-read-dribble-file
775 "Gnus auto-save file exists. Do you want to read it? ") 813 (gnus-y-or-n-p
814 "Gnus auto-save file exists. Do you want to read it? "))
776 (setq gnus-dribble-eval-file t))))))) 815 (setq gnus-dribble-eval-file t)))))))
777 816
778(defun gnus-dribble-eval-file () 817(defun gnus-dribble-eval-file ()
@@ -828,8 +867,10 @@ If LEVEL is non-nil, the news will be set up at level LEVEL."
828 ;; Read the newsrc file and create `gnus-newsrc-hashtb'. 867 ;; Read the newsrc file and create `gnus-newsrc-hashtb'.
829 (gnus-read-newsrc-file rawfile)) 868 (gnus-read-newsrc-file rawfile))
830 869
831 (when (and (not (assoc "archive" gnus-server-alist)) 870 ;; Make sure the archive server is available to all and sundry.
832 (gnus-archive-server-wanted-p)) 871 (when gnus-message-archive-method
872 (setq gnus-server-alist (delq (assoc "archive" gnus-server-alist)
873 gnus-server-alist))
833 (push (cons "archive" gnus-message-archive-method) 874 (push (cons "archive" gnus-message-archive-method)
834 gnus-server-alist)) 875 gnus-server-alist))
835 876
@@ -877,7 +918,8 @@ If LEVEL is non-nil, the news will be set up at level LEVEL."
877 ;; Find new newsgroups and treat them. 918 ;; Find new newsgroups and treat them.
878 (when (and init gnus-check-new-newsgroups (not level) 919 (when (and init gnus-check-new-newsgroups (not level)
879 (gnus-check-server gnus-select-method) 920 (gnus-check-server gnus-select-method)
880 (not gnus-slave)) 921 (not gnus-slave)
922 gnus-plugged)
881 (gnus-find-new-newsgroups)) 923 (gnus-find-new-newsgroups))
882 924
883 ;; We might read in new NoCeM messages here. 925 ;; We might read in new NoCeM messages here.
@@ -902,13 +944,25 @@ If LEVEL is non-nil, the news will be set up at level LEVEL."
902 "Search for new newsgroups and add them. 944 "Search for new newsgroups and add them.
903Each new newsgroup will be treated with `gnus-subscribe-newsgroup-method.' 945Each new newsgroup will be treated with `gnus-subscribe-newsgroup-method.'
904The `-n' option line from .newsrc is respected. 946The `-n' option line from .newsrc is respected.
905If ARG (the prefix), use the `ask-server' method to query the server 947
906for new groups." 948With 1 C-u, use the `ask-server' method to query the server for new
907 (interactive "P") 949groups.
908 (let ((check (if (or (and arg (not (listp gnus-check-new-newsgroups))) 950With 2 C-u's, use most complete method possible to query the server
909 (null gnus-read-active-file) 951for new groups, and subscribe the new groups as zombies."
910 (eq gnus-read-active-file 'some)) 952 (interactive "p")
911 'ask-server gnus-check-new-newsgroups))) 953 (let* ((gnus-subscribe-newsgroup-method
954 gnus-subscribe-newsgroup-method)
955 (check (cond
956 ((or (and (= (or arg 1) 4)
957 (not (listp gnus-check-new-newsgroups)))
958 (null gnus-read-active-file)
959 (eq gnus-read-active-file 'some))
960 'ask-server)
961 ((= (or arg 1) 16)
962 (setq gnus-subscribe-newsgroup-method
963 'gnus-subscribe-zombies)
964 t)
965 (t gnus-check-new-newsgroups))))
912 (unless (gnus-check-first-time-used) 966 (unless (gnus-check-first-time-used)
913 (if (or (consp check) 967 (if (or (consp check)
914 (eq check 'ask-server)) 968 (eq check 'ask-server))
@@ -996,16 +1050,18 @@ for new groups."
996 (new-date (current-time-string)) 1050 (new-date (current-time-string))
997 group new-newsgroups got-new method hashtb 1051 group new-newsgroups got-new method hashtb
998 gnus-override-subscribe-method) 1052 gnus-override-subscribe-method)
1053 (unless gnus-killed-hashtb
1054 (gnus-make-hashtable-from-killed))
999 ;; Go through both primary and secondary select methods and 1055 ;; Go through both primary and secondary select methods and
1000 ;; request new newsgroups. 1056 ;; request new newsgroups.
1001 (while (setq method (gnus-server-get-method nil (pop methods))) 1057 (while (setq method (gnus-server-get-method nil (pop methods)))
1002 (setq new-newsgroups nil) 1058 (setq new-newsgroups nil
1003 (setq gnus-override-subscribe-method method) 1059 gnus-override-subscribe-method method)
1004 (when (and (gnus-check-server method) 1060 (when (and (gnus-check-server method)
1005 (gnus-request-newgroups date method)) 1061 (gnus-request-newgroups date method))
1006 (save-excursion 1062 (save-excursion
1007 (setq got-new t) 1063 (setq got-new t
1008 (setq hashtb (gnus-make-hashtable 100)) 1064 hashtb (gnus-make-hashtable 100))
1009 (set-buffer nntp-server-buffer) 1065 (set-buffer nntp-server-buffer)
1010 ;; Enter all the new groups into a hashtable. 1066 ;; Enter all the new groups into a hashtable.
1011 (gnus-active-to-gnus-format method hashtb 'ignore)) 1067 (gnus-active-to-gnus-format method hashtb 'ignore))
@@ -1041,10 +1097,10 @@ for new groups."
1041 hashtb)) 1097 hashtb))
1042 (when new-newsgroups 1098 (when new-newsgroups
1043 (gnus-subscribe-hierarchical-interactive new-newsgroups))) 1099 (gnus-subscribe-hierarchical-interactive new-newsgroups)))
1044 ;; Suggested by Per Abrahamsen <amanda@iesd.auc.dk>. 1100 (if (> groups 0)
1045 (when (> groups 0) 1101 (gnus-message 5 "%d new newsgroup%s arrived"
1046 (gnus-message 6 "%d new newsgroup%s arrived." 1102 groups (if (> groups 1) "s have" " has"))
1047 groups (if (> groups 1) "s have" " has"))) 1103 (gnus-message 5 "No new newsgroups"))
1048 (when got-new 1104 (when got-new
1049 (setq gnus-newsrc-last-checked-date new-date)) 1105 (setq gnus-newsrc-last-checked-date new-date))
1050 got-new)) 1106 got-new))
@@ -1128,7 +1184,7 @@ for new groups."
1128 (if (and (not oldlevel) 1184 (if (and (not oldlevel)
1129 (consp entry)) 1185 (consp entry))
1130 (setq oldlevel (gnus-info-level (nth 2 entry))) 1186 (setq oldlevel (gnus-info-level (nth 2 entry)))
1131 (setq oldlevel (or oldlevel 9))) 1187 (setq oldlevel (or oldlevel gnus-level-killed)))
1132 (when (stringp previous) 1188 (when (stringp previous)
1133 (setq previous (gnus-gethash previous gnus-newsrc-hashtb))) 1189 (setq previous (gnus-gethash previous gnus-newsrc-hashtb)))
1134 1190
@@ -1274,7 +1330,7 @@ newsgroup."
1274 (set (car dead-lists) 1330 (set (car dead-lists)
1275 (delete group (symbol-value (car dead-lists)))))) 1331 (delete group (symbol-value (car dead-lists))))))
1276 (setq dead-lists (cdr dead-lists)))) 1332 (setq dead-lists (cdr dead-lists))))
1277 (run-hooks 'gnus-check-bogus-groups-hook) 1333 (gnus-run-hooks 'gnus-check-bogus-groups-hook)
1278 (gnus-message 5 "Checking bogus newsgroups...done")))) 1334 (gnus-message 5 "Checking bogus newsgroups...done"))))
1279 1335
1280(defun gnus-check-duplicate-killed-groups () 1336(defun gnus-check-duplicate-killed-groups ()
@@ -1338,6 +1394,7 @@ newsgroup."
1338 info (inline (gnus-find-method-for-group 1394 info (inline (gnus-find-method-for-group
1339 (gnus-info-group info))))) 1395 (gnus-info-group info)))))
1340 (gnus-activate-group (gnus-info-group info) nil t)) 1396 (gnus-activate-group (gnus-info-group info) nil t))
1397
1341 (let* ((range (gnus-info-read info)) 1398 (let* ((range (gnus-info-read info))
1342 (num 0)) 1399 (num 0))
1343 ;; If a cache is present, we may have to alter the active info. 1400 ;; If a cache is present, we may have to alter the active info.
@@ -1449,6 +1506,10 @@ newsgroup."
1449 ;; These groups are foreign. Check the level. 1506 ;; These groups are foreign. Check the level.
1450 (when (<= (gnus-info-level info) foreign-level) 1507 (when (<= (gnus-info-level info) foreign-level)
1451 (setq active (gnus-activate-group group 'scan)) 1508 (setq active (gnus-activate-group group 'scan))
1509 ;; Let the Gnus agent save the active file.
1510 (when (and gnus-agent gnus-plugged active)
1511 (gnus-agent-save-group-info
1512 method (gnus-group-real-name group) active))
1452 (unless (inline (gnus-virtual-group-p group)) 1513 (unless (inline (gnus-virtual-group-p group))
1453 (inline (gnus-close-group group))) 1514 (inline (gnus-close-group group)))
1454 (when (fboundp (intern (concat (symbol-name (car method)) 1515 (when (fboundp (intern (concat (symbol-name (car method))
@@ -1628,9 +1689,11 @@ newsgroup."
1628 1.2 "Cannot read partial active file from %s server." 1689 1.2 "Cannot read partial active file from %s server."
1629 (car method))) 1690 (car method)))
1630 ((eq list-type 'active) 1691 ((eq list-type 'active)
1631 (gnus-active-to-gnus-format method gnus-active-hashtb)) 1692 (gnus-active-to-gnus-format
1693 method gnus-active-hashtb nil t))
1632 (t 1694 (t
1633 (gnus-groups-to-gnus-format method gnus-active-hashtb)))))) 1695 (gnus-groups-to-gnus-format
1696 method gnus-active-hashtb t))))))
1634 ((null method) 1697 ((null method)
1635 t) 1698 t)
1636 (t 1699 (t
@@ -1639,7 +1702,7 @@ newsgroup."
1639 (gnus-error 1 "Cannot read active file from %s server" 1702 (gnus-error 1 "Cannot read active file from %s server"
1640 (car method))) 1703 (car method)))
1641 (gnus-message 5 mesg) 1704 (gnus-message 5 mesg)
1642 (gnus-active-to-gnus-format method gnus-active-hashtb) 1705 (gnus-active-to-gnus-format method gnus-active-hashtb nil t)
1643 ;; We mark this active file as read. 1706 ;; We mark this active file as read.
1644 (push method gnus-have-read-active-file) 1707 (push method gnus-have-read-active-file)
1645 (gnus-message 5 "%sdone" mesg)))))) 1708 (gnus-message 5 "%sdone" mesg))))))
@@ -1647,14 +1710,14 @@ newsgroup."
1647 1710
1648 1711
1649(defun gnus-ignored-newsgroups-has-to-p () 1712(defun gnus-ignored-newsgroups-has-to-p ()
1650 "T only when gnus-ignored-newsgroups includes \"^to\\\\.\" as an element." 1713 "Non-nil iff gnus-ignored-newsgroups includes \"^to\\\\.\" as an element."
1651 ;; note this regexp is the same as: 1714 ;; note this regexp is the same as:
1652 ;; (concat (regexp-quote "^to\\.") "\\($\\|" (regexp-quote "\\|") "\\)") 1715 ;; (concat (regexp-quote "^to\\.") "\\($\\|" (regexp-quote "\\|") "\\)")
1653 (string-match "\\^to\\\\\\.\\($\\|\\\\|\\)" 1716 (string-match "\\^to\\\\\\.\\($\\|\\\\|\\)" gnus-ignored-newsgroups))
1654 gnus-ignored-newsgroups))
1655 1717
1656;; Read an active file and place the results in `gnus-active-hashtb'. 1718;; Read an active file and place the results in `gnus-active-hashtb'.
1657(defun gnus-active-to-gnus-format (&optional method hashtb ignore-errors) 1719(defun gnus-active-to-gnus-format (&optional method hashtb ignore-errors
1720 real-active)
1658 (unless method 1721 (unless method
1659 (setq method gnus-select-method)) 1722 (setq method gnus-select-method))
1660 (let ((cur (current-buffer)) 1723 (let ((cur (current-buffer))
@@ -1683,6 +1746,10 @@ newsgroup."
1683 (while (re-search-backward "[][';?()#]" nil t) 1746 (while (re-search-backward "[][';?()#]" nil t)
1684 (insert ?\\)) 1747 (insert ?\\))
1685 1748
1749 ;; Let the Gnus agent save the active file.
1750 (when (and gnus-agent real-active)
1751 (gnus-agent-save-active method))
1752
1686 ;; If these are groups from a foreign select method, we insert the 1753 ;; If these are groups from a foreign select method, we insert the
1687 ;; group prefix in front of the group names. 1754 ;; group prefix in front of the group names.
1688 (when (not (gnus-server-equal 1755 (when (not (gnus-server-equal
@@ -1731,7 +1798,7 @@ newsgroup."
1731 (widen) 1798 (widen)
1732 (forward-line 1))))) 1799 (forward-line 1)))))
1733 1800
1734(defun gnus-groups-to-gnus-format (method &optional hashtb) 1801(defun gnus-groups-to-gnus-format (method &optional hashtb real-active)
1735 ;; Parse a "groups" active file. 1802 ;; Parse a "groups" active file.
1736 (let ((cur (current-buffer)) 1803 (let ((cur (current-buffer))
1737 (hashtb (or hashtb 1804 (hashtb (or hashtb
@@ -1746,6 +1813,10 @@ newsgroup."
1746 (gnus-server-get-method nil gnus-select-method))) 1813 (gnus-server-get-method nil gnus-select-method)))
1747 (gnus-group-prefixed-name "" method)))) 1814 (gnus-group-prefixed-name "" method))))
1748 1815
1816 ;; Let the Gnus agent save the active file.
1817 (when (and gnus-agent real-active)
1818 (gnus-agent-save-groups method))
1819
1749 (goto-char (point-min)) 1820 (goto-char (point-min))
1750 ;; We split this into to separate loops, one with the prefix 1821 ;; We split this into to separate loops, one with the prefix
1751 ;; and one without to speed the reading up somewhat. 1822 ;; and one without to speed the reading up somewhat.
@@ -1928,7 +1999,8 @@ If FORCE is non-nil, the .newsrc file is read."
1928 (if (or (file-exists-p real-file) 1999 (if (or (file-exists-p real-file)
1929 (file-exists-p (concat real-file ".el")) 2000 (file-exists-p (concat real-file ".el"))
1930 (file-exists-p (concat real-file ".eld"))) 2001 (file-exists-p (concat real-file ".eld")))
1931 real-file file))) 2002 real-file
2003 file)))
1932 2004
1933(defun gnus-newsrc-to-gnus-format () 2005(defun gnus-newsrc-to-gnus-format ()
1934 (setq gnus-newsrc-options "") 2006 (setq gnus-newsrc-options "")
@@ -2164,11 +2236,12 @@ If FORCE is non-nil, the .newsrc file is read."
2164 (push (cons (concat 2236 (push (cons (concat
2165 "^" (buffer-substring 2237 "^" (buffer-substring
2166 (1+ (match-beginning 0)) 2238 (1+ (match-beginning 0))
2167 (match-end 0))) 2239 (match-end 0))
2240 "\\($\\|\\.\\)")
2168 'ignore) 2241 'ignore)
2169 out) 2242 out)
2170 ;; There was no bang, so this is a "yes" spec. 2243 ;; There was no bang, so this is a "yes" spec.
2171 (push (cons (concat "^" (match-string 0)) 2244 (push (cons (concat "^" (match-string 0) "\\($\\|\\.\\)")
2172 'subscribe) 2245 'subscribe)
2173 out)))) 2246 out))))
2174 2247
@@ -2189,7 +2262,7 @@ If FORCE is non-nil, the .newsrc file is read."
2189 (set-buffer gnus-dribble-buffer) 2262 (set-buffer gnus-dribble-buffer)
2190 (buffer-size))))) 2263 (buffer-size)))))
2191 (gnus-message 4 "(No changes need to be saved)") 2264 (gnus-message 4 "(No changes need to be saved)")
2192 (run-hooks 'gnus-save-newsrc-hook) 2265 (gnus-run-hooks 'gnus-save-newsrc-hook)
2193 (if gnus-slave 2266 (if gnus-slave
2194 (gnus-slave-save-newsrc) 2267 (gnus-slave-save-newsrc)
2195 ;; Save .newsrc. 2268 ;; Save .newsrc.
@@ -2198,18 +2271,17 @@ If FORCE is non-nil, the .newsrc file is read."
2198 (gnus-gnus-to-newsrc-format) 2271 (gnus-gnus-to-newsrc-format)
2199 (gnus-message 8 "Saving %s...done" gnus-current-startup-file)) 2272 (gnus-message 8 "Saving %s...done" gnus-current-startup-file))
2200 ;; Save .newsrc.eld. 2273 ;; Save .newsrc.eld.
2201 (set-buffer (get-buffer-create " *Gnus-newsrc*")) 2274 (set-buffer (gnus-get-buffer-create " *Gnus-newsrc*"))
2202 (make-local-variable 'version-control) 2275 (make-local-variable 'version-control)
2203 (setq version-control 'never) 2276 (setq version-control 'never)
2204 (setq buffer-file-name 2277 (setq buffer-file-name
2205 (concat gnus-current-startup-file ".eld")) 2278 (concat gnus-current-startup-file ".eld"))
2206 (setq default-directory (file-name-directory buffer-file-name)) 2279 (setq default-directory (file-name-directory buffer-file-name))
2207 (gnus-add-current-to-buffer-list)
2208 (buffer-disable-undo (current-buffer)) 2280 (buffer-disable-undo (current-buffer))
2209 (erase-buffer) 2281 (erase-buffer)
2210 (gnus-message 5 "Saving %s.eld..." gnus-current-startup-file) 2282 (gnus-message 5 "Saving %s.eld..." gnus-current-startup-file)
2211 (gnus-gnus-to-quick-newsrc-format) 2283 (gnus-gnus-to-quick-newsrc-format)
2212 (run-hooks 'gnus-save-quick-newsrc-hook) 2284 (gnus-run-hooks 'gnus-save-quick-newsrc-hook)
2213 (let ((coding-system-for-write gnus-startup-file-coding-system)) 2285 (let ((coding-system-for-write gnus-startup-file-coding-system))
2214 (save-buffer)) 2286 (save-buffer))
2215 (kill-buffer (current-buffer)) 2287 (kill-buffer (current-buffer))
@@ -2224,9 +2296,9 @@ If FORCE is non-nil, the .newsrc file is read."
2224 (print-escape-newlines t)) 2296 (print-escape-newlines t))
2225 (insert ";; -*- emacs-lisp -*-\n") 2297 (insert ";; -*- emacs-lisp -*-\n")
2226 (insert ";; Gnus startup file.\n") 2298 (insert ";; Gnus startup file.\n")
2227 (insert 2299 (insert "\
2228 ";; Never delete this file - touch .newsrc instead to force Gnus\n") 2300;; Never delete this file -- if you want to force Gnus to read the
2229 (insert ";; to read .newsrc.\n") 2301;; .newsrc file (if you have one), touch .newsrc instead.\n")
2230 (insert "(setq gnus-newsrc-file-version " 2302 (insert "(setq gnus-newsrc-file-version "
2231 (prin1-to-string gnus-version) ")\n") 2303 (prin1-to-string gnus-version) ")\n")
2232 (let* ((gnus-killed-list 2304 (let* ((gnus-killed-list
@@ -2255,7 +2327,7 @@ If FORCE is non-nil, the .newsrc file is read."
2255 (let ((list gnus-killed-list) 2327 (let ((list gnus-killed-list)
2256 olist) 2328 olist)
2257 (while list 2329 (while list
2258 (when (string-match gnus-save-killed-list) 2330 (when (string-match gnus-save-killed-list (car list))
2259 (push (car list) olist)) 2331 (push (car list) olist))
2260 (pop list)) 2332 (pop list))
2261 (nreverse olist))) 2333 (nreverse olist)))
@@ -2312,7 +2384,7 @@ If FORCE is non-nil, the .newsrc file is read."
2312 (if gnus-modtime-botch 2384 (if gnus-modtime-botch
2313 (delete-file gnus-startup-file) 2385 (delete-file gnus-startup-file)
2314 (clear-visited-file-modtime)) 2386 (clear-visited-file-modtime))
2315 (run-hooks 'gnus-save-standard-newsrc-hook) 2387 (gnus-run-hooks 'gnus-save-standard-newsrc-hook)
2316 (save-buffer) 2388 (save-buffer)
2317 (kill-buffer (current-buffer))))) 2389 (kill-buffer (current-buffer)))))
2318 2390
@@ -2321,6 +2393,13 @@ If FORCE is non-nil, the .newsrc file is read."
2321;;; Slave functions. 2393;;; Slave functions.
2322;;; 2394;;;
2323 2395
2396(defvar gnus-slave-mode nil)
2397
2398(defun gnus-slave-mode ()
2399 "Minor mode for slave Gnusae."
2400 (gnus-add-minor-mode 'gnus-slave-mode " Slave" (make-sparse-keymap))
2401 (gnus-run-hooks 'gnus-slave-mode-hook))
2402
2324(defun gnus-slave-save-newsrc () 2403(defun gnus-slave-save-newsrc ()
2325 (save-excursion 2404 (save-excursion
2326 (set-buffer gnus-dribble-buffer) 2405 (set-buffer gnus-dribble-buffer)
@@ -2347,7 +2426,7 @@ If FORCE is non-nil, the .newsrc file is read."
2347 () ; There are no slave files to read. 2426 () ; There are no slave files to read.
2348 (gnus-message 7 "Reading slave newsrcs...") 2427 (gnus-message 7 "Reading slave newsrcs...")
2349 (save-excursion 2428 (save-excursion
2350 (set-buffer (get-buffer-create " *gnus slave*")) 2429 (set-buffer (gnus-get-buffer-create " *gnus slave*"))
2351 (buffer-disable-undo (current-buffer)) 2430 (buffer-disable-undo (current-buffer))
2352 (setq slave-files 2431 (setq slave-files
2353 (sort (mapcar (lambda (file) 2432 (sort (mapcar (lambda (file)
@@ -2450,10 +2529,12 @@ If FORCE is non-nil, the .newsrc file is read."
2450 (let ((str (buffer-substring 2529 (let ((str (buffer-substring
2451 (point) (progn (end-of-line) (point)))) 2530 (point) (progn (end-of-line) (point))))
2452 (coding 2531 (coding
2453 (and enable-multibyte-characters 2532 (and (boundp 'enable-multibyte-characters)
2533 enable-multibyte-characters
2534 (fboundp 'gnus-mule-get-coding-system)
2454 (gnus-mule-get-coding-system (symbol-name group))))) 2535 (gnus-mule-get-coding-system (symbol-name group)))))
2455 (if coding 2536 (if coding
2456 (setq str (decode-coding-string str (car coding)))) 2537 (setq str (gnus-decode-coding-string str (car coding))))
2457 (set group str))) 2538 (set group str)))
2458 (forward-line 1)))) 2539 (forward-line 1))))
2459 (gnus-message 5 "Reading descriptions file...done") 2540 (gnus-message 5 "Reading descriptions file...done")
diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el
index d48cce763ab..8445b475db1 100644
--- a/lisp/gnus/gnus-sum.el
+++ b/lisp/gnus/gnus-sum.el
@@ -1,7 +1,7 @@
1;;; gnus-sum.el --- summary mode commands for Gnus 1;;; gnus-sum.el --- summary mode commands for Gnus
2;; Copyright (C) 1996,97 Free Software Foundation, Inc. 2;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: news 5;; Keywords: news
6 6
7;; This file is part of GNU Emacs. 7;; This file is part of GNU Emacs.
@@ -27,12 +27,16 @@
27 27
28(eval-when-compile (require 'cl)) 28(eval-when-compile (require 'cl))
29 29
30(eval-when-compile (require 'cl))
31
30(require 'gnus) 32(require 'gnus)
31(require 'gnus-group) 33(require 'gnus-group)
32(require 'gnus-spec) 34(require 'gnus-spec)
33(require 'gnus-range) 35(require 'gnus-range)
34(require 'gnus-int) 36(require 'gnus-int)
35(require 'gnus-undo) 37(require 'gnus-undo)
38(require 'gnus-util)
39(autoload 'gnus-summary-limit-include-cached "gnus-cache" nil t)
36 40
37(defcustom gnus-kill-summary-on-exit t 41(defcustom gnus-kill-summary-on-exit t
38 "*If non-nil, kill the summary buffer when you exit from it. 42 "*If non-nil, kill the summary buffer when you exit from it.
@@ -47,10 +51,11 @@ If an unread article in the group refers to an older, already read (or
47just marked as read) article, the old article will not normally be 51just marked as read) article, the old article will not normally be
48displayed in the Summary buffer. If this variable is non-nil, Gnus 52displayed in the Summary buffer. If this variable is non-nil, Gnus
49will attempt to grab the headers to the old articles, and thereby 53will attempt to grab the headers to the old articles, and thereby
50build complete threads. If it has the value `some', only enough 54build complete threads. If it has the value `some', only enough
51headers to connect otherwise loose threads will be displayed. 55headers to connect otherwise loose threads will be displayed. This
52This variable can also be a number. In that case, no more than that 56variable can also be a number. In that case, no more than that number
53number of old headers will be fetched. 57of old headers will be fetched. If it has the value `invisible', all
58old headers will be fetched, but none will be displayed.
54 59
55The server has to support NOV for any of this to work." 60The server has to support NOV for any of this to work."
56 :group 'gnus-thread 61 :group 'gnus-thread
@@ -59,6 +64,13 @@ The server has to support NOV for any of this to work."
59 number 64 number
60 (sexp :menu-tag "other" t))) 65 (sexp :menu-tag "other" t)))
61 66
67(defcustom gnus-refer-thread-limit 200
68 "*The number of old headers to fetch when doing \\<gnus-summary-mode-map>\\[gnus-summary-refer-thread].
69If t, fetch all the available old headers."
70 :group 'gnus-thread
71 :type '(choice number
72 (sexp :menu-tag "other" t)))
73
62(defcustom gnus-summary-make-false-root 'adopt 74(defcustom gnus-summary-make-false-root 'adopt
63 "*nil means that Gnus won't gather loose threads. 75 "*nil means that Gnus won't gather loose threads.
64If the root of a thread has expired or been read in a previous 76If the root of a thread has expired or been read in a previous
@@ -111,6 +123,15 @@ comparing subjects."
111 (const fuzzy) 123 (const fuzzy)
112 (sexp :menu-tag "on" t))) 124 (sexp :menu-tag "on" t)))
113 125
126(defcustom gnus-simplify-subject-functions nil
127 "List of functions taking a string argument that simplify subjects.
128The functions are applied recursively.
129
130Useful functions to put in this list include: `gnus-simplify-subject-re',
131`gnus-simplify-subject-fuzzy' and `gnus-simplify-whitespace'."
132 :group 'gnus-thread
133 :type '(repeat function))
134
114(defcustom gnus-simplify-ignored-prefixes nil 135(defcustom gnus-simplify-ignored-prefixes nil
115 "*Regexp, matches for which are removed from subject lines when simplifying fuzzily." 136 "*Regexp, matches for which are removed from subject lines when simplifying fuzzily."
116 :group 'gnus-thread 137 :group 'gnus-thread
@@ -130,7 +151,7 @@ non-nil and non-`some', fill in all gaps that Gnus manages to guess."
130 151
131(defcustom gnus-summary-thread-gathering-function 152(defcustom gnus-summary-thread-gathering-function
132 'gnus-gather-threads-by-subject 153 'gnus-gather-threads-by-subject
133 "Function used for gathering loose threads. 154 "*Function used for gathering loose threads.
134There are two pre-defined functions: `gnus-gather-threads-by-subject', 155There are two pre-defined functions: `gnus-gather-threads-by-subject',
135which only takes Subjects into consideration; and 156which only takes Subjects into consideration; and
136`gnus-gather-threads-by-references', which compared the References 157`gnus-gather-threads-by-references', which compared the References
@@ -140,7 +161,6 @@ headers of the articles to find matches."
140 (function-item gnus-gather-threads-by-references) 161 (function-item gnus-gather-threads-by-references)
141 (function :tag "other"))) 162 (function :tag "other")))
142 163
143;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
144(defcustom gnus-summary-same-subject "" 164(defcustom gnus-summary-same-subject ""
145 "*String indicating that the current article has the same subject as the previous. 165 "*String indicating that the current article has the same subject as the previous.
146This variable will only be used if the value of 166This variable will only be used if the value of
@@ -200,10 +220,10 @@ to expose hidden threads."
200 :group 'gnus-thread 220 :group 'gnus-thread
201 :type 'boolean) 221 :type 'boolean)
202 222
203(defcustom gnus-thread-ignore-subject nil 223(defcustom gnus-thread-ignore-subject t
204 "*If non-nil, ignore subjects and do all threading based on the Reference header. 224 "*If non-nil, which is the default, ignore subjects and do all threading based on the Reference header.
205If nil, which is the default, articles that have different subjects 225If nil, articles that have different subjects from their parents will
206from their parents will start separate threads." 226start separate threads."
207 :group 'gnus-thread 227 :group 'gnus-thread
208 :type 'boolean) 228 :type 'boolean)
209 229
@@ -264,7 +284,9 @@ will go to the next group without confirmation."
264 (sexp :menu-tag "on" t))) 284 (sexp :menu-tag "on" t)))
265 285
266(defcustom gnus-auto-select-same nil 286(defcustom gnus-auto-select-same nil
267 "*If non-nil, select the next article with the same subject." 287 "*If non-nil, select the next article with the same subject.
288If there are no more articles with the same subject, go to
289the first unread article."
268 :group 'gnus-summary-maneuvering 290 :group 'gnus-summary-maneuvering
269 :type 'boolean) 291 :type 'boolean)
270 292
@@ -294,7 +316,7 @@ and non-`vertical', do both horizontal and vertical recentering."
294 "*If non-nil, ignore articles with identical Message-ID headers." 316 "*If non-nil, ignore articles with identical Message-ID headers."
295 :group 'gnus-summary 317 :group 'gnus-summary
296 :type 'boolean) 318 :type 'boolean)
297 319
298(defcustom gnus-single-article-buffer t 320(defcustom gnus-single-article-buffer t
299 "*If non-nil, display all articles in the same buffer. 321 "*If non-nil, display all articles in the same buffer.
300If nil, each group will get its own article buffer." 322If nil, each group will get its own article buffer."
@@ -319,11 +341,11 @@ The articles will simply be fed to the function given by
319 "*Variable used to suggest where articles are to be moved to. 341 "*Variable used to suggest where articles are to be moved to.
320It uses the same syntax as the `gnus-split-methods' variable." 342It uses the same syntax as the `gnus-split-methods' variable."
321 :group 'gnus-summary-mail 343 :group 'gnus-summary-mail
322 :type '(repeat (choice (list function) 344 :type '(repeat (choice (list :value (fun) function)
323 (cons regexp (repeat string)) 345 (cons :value ("" "") regexp (repeat string))
324 sexp))) 346 (sexp :value nil))))
325 347
326(defcustom gnus-unread-mark ? 348(defcustom gnus-unread-mark ? ;space
327 "*Mark used for unread articles." 349 "*Mark used for unread articles."
328 :group 'gnus-summary-marks 350 :group 'gnus-summary-marks
329 :type 'character) 351 :type 'character)
@@ -413,6 +435,21 @@ It uses the same syntax as the `gnus-split-methods' variable."
413 :group 'gnus-summary-marks 435 :group 'gnus-summary-marks
414 :type 'character) 436 :type 'character)
415 437
438(defcustom gnus-undownloaded-mark ?@
439 "*Mark used for articles that weren't downloaded."
440 :group 'gnus-summary-marks
441 :type 'character)
442
443(defcustom gnus-downloadable-mark ?%
444 "*Mark used for articles that are to be downloaded."
445 :group 'gnus-summary-marks
446 :type 'character)
447
448(defcustom gnus-unsendable-mark ?=
449 "*Mark used for articles that won't be sent."
450 :group 'gnus-summary-marks
451 :type 'character)
452
416(defcustom gnus-score-over-mark ?+ 453(defcustom gnus-score-over-mark ?+
417 "*Score mark used for articles with high scores." 454 "*Score mark used for articles with high scores."
418 :group 'gnus-summary-marks 455 :group 'gnus-summary-marks
@@ -423,7 +460,7 @@ It uses the same syntax as the `gnus-split-methods' variable."
423 :group 'gnus-summary-marks 460 :group 'gnus-summary-marks
424 :type 'character) 461 :type 'character)
425 462
426(defcustom gnus-empty-thread-mark ? 463(defcustom gnus-empty-thread-mark ? ;space
427 "*There is no thread under the article." 464 "*There is no thread under the article."
428 :group 'gnus-summary-marks 465 :group 'gnus-summary-marks
429 :type 'character) 466 :type 'character)
@@ -460,7 +497,7 @@ list of parameters to that command."
460 :type 'boolean) 497 :type 'boolean)
461 498
462(defcustom gnus-summary-dummy-line-format 499(defcustom gnus-summary-dummy-line-format
463 "* %(: :%) %S\n" 500 " %(: :%) %S\n"
464 "*The format specification for the dummy roots in the summary buffer. 501 "*The format specification for the dummy roots in the summary buffer.
465It works along the same lines as a normal formatting string, 502It works along the same lines as a normal formatting string,
466with some simple extensions. 503with some simple extensions.
@@ -477,6 +514,7 @@ with some simple extensions:
477%G Group name 514%G Group name
478%p Unprefixed group name 515%p Unprefixed group name
479%A Current article number 516%A Current article number
517%z Current article score
480%V Gnus version 518%V Gnus version
481%U Number of unread articles in the group 519%U Number of unread articles in the group
482%e Number of unselected articles in the group 520%e Number of unselected articles in the group
@@ -543,7 +581,8 @@ Some functions you can use are `+', `max', or `min'."
543 :type 'function) 581 :type 'function)
544 582
545(defcustom gnus-summary-expunge-below nil 583(defcustom gnus-summary-expunge-below nil
546 "All articles that have a score less than this variable will be expunged." 584 "All articles that have a score less than this variable will be expunged.
585This variable is local to the summary buffers."
547 :group 'gnus-score-default 586 :group 'gnus-score-default
548 :type '(choice (const :tag "off" nil) 587 :type '(choice (const :tag "off" nil)
549 integer)) 588 integer))
@@ -551,7 +590,9 @@ Some functions you can use are `+', `max', or `min'."
551(defcustom gnus-thread-expunge-below nil 590(defcustom gnus-thread-expunge-below nil
552 "All threads that have a total score less than this variable will be expunged. 591 "All threads that have a total score less than this variable will be expunged.
553See `gnus-thread-score-function' for en explanation of what a 592See `gnus-thread-score-function' for en explanation of what a
554\"thread score\" is." 593\"thread score\" is.
594
595This variable is local to the summary buffers."
555 :group 'gnus-treading 596 :group 'gnus-treading
556 :group 'gnus-score-default 597 :group 'gnus-score-default
557 :type '(choice (const :tag "off" nil) 598 :type '(choice (const :tag "off" nil)
@@ -580,6 +621,11 @@ If you want to modify the summary buffer, you can use this hook."
580 :group 'gnus-summary-various 621 :group 'gnus-summary-various
581 :type 'hook) 622 :type 'hook)
582 623
624(defcustom gnus-summary-prepared-hook nil
625 "*A hook called as the last thing after the summary buffer has been generated."
626 :group 'gnus-summary-various
627 :type 'hook)
628
583(defcustom gnus-summary-generate-hook nil 629(defcustom gnus-summary-generate-hook nil
584 "*A hook run just before generating the summary buffer. 630 "*A hook run just before generating the summary buffer.
585This hook is commonly used to customize threading variables and the 631This hook is commonly used to customize threading variables and the
@@ -619,7 +665,6 @@ is not run if `gnus-visual' is nil."
619 :group 'gnus-summary-visual 665 :group 'gnus-summary-visual
620 :type 'hook) 666 :type 'hook)
621 667
622;; 1997/5/4 by MORIOKA Tomohiko <morioka@jaist.ac.jp>
623(defcustom gnus-structured-field-decoder 668(defcustom gnus-structured-field-decoder
624 (if (and (featurep 'mule) 669 (if (and (featurep 'mule)
625 (boundp 'enable-multibyte-characters)) 670 (boundp 'enable-multibyte-characters))
@@ -712,7 +757,15 @@ automatically when it is selected."
712 . gnus-summary-high-unread-face) 757 . gnus-summary-high-unread-face)
713 ((and (< score default) (= mark gnus-unread-mark)) 758 ((and (< score default) (= mark gnus-unread-mark))
714 . gnus-summary-low-unread-face) 759 . gnus-summary-low-unread-face)
715 ((and (= mark gnus-unread-mark)) 760 ((= mark gnus-unread-mark)
761 . gnus-summary-normal-unread-face)
762 ((and (> score default) (memq mark (list gnus-downloadable-mark
763 gnus-undownloaded-mark)))
764 . gnus-summary-high-unread-face)
765 ((and (< score default) (memq mark (list gnus-downloadable-mark
766 gnus-undownloaded-mark)))
767 . gnus-summary-low-unread-face)
768 ((memq mark (list gnus-downloadable-mark gnus-undownloaded-mark))
716 . gnus-summary-normal-unread-face) 769 . gnus-summary-normal-unread-face)
717 ((> score default) 770 ((> score default)
718 . gnus-summary-high-read-face) 771 . gnus-summary-high-read-face)
@@ -720,7 +773,7 @@ automatically when it is selected."
720 . gnus-summary-low-read-face) 773 . gnus-summary-low-read-face)
721 (t 774 (t
722 . gnus-summary-normal-read-face)) 775 . gnus-summary-normal-read-face))
723 "Controls the highlighting of summary buffer lines. 776 "*Controls the highlighting of summary buffer lines.
724 777
725A list of (FORM . FACE) pairs. When deciding how a a particular 778A list of (FORM . FACE) pairs. When deciding how a a particular
726summary line should be displayed, each form is evaluated. The content 779summary line should be displayed, each form is evaluated. The content
@@ -737,6 +790,10 @@ mark: The articles mark."
737 :type '(repeat (cons (sexp :tag "Form" nil) 790 :type '(repeat (cons (sexp :tag "Form" nil)
738 face))) 791 face)))
739 792
793(defcustom gnus-alter-header-function nil
794 "Function called to allow alteration of article header structures.
795The function is called with one parameter, the article header vector,
796which it may alter in any way.")
740 797
741;;; Internal variables 798;;; Internal variables
742 799
@@ -779,7 +836,7 @@ mark: The articles mark."
779 (?x ,(macroexpand '(mail-header-xref gnus-tmp-header)) ?s) 836 (?x ,(macroexpand '(mail-header-xref gnus-tmp-header)) ?s)
780 (?D ,(macroexpand '(mail-header-date gnus-tmp-header)) ?s) 837 (?D ,(macroexpand '(mail-header-date gnus-tmp-header)) ?s)
781 (?d (gnus-dd-mmm (mail-header-date gnus-tmp-header)) ?s) 838 (?d (gnus-dd-mmm (mail-header-date gnus-tmp-header)) ?s)
782 (?o (gnus-date-iso8601 gnus-tmp-header) ?s) 839 (?o (gnus-date-iso8601 (mail-header-date gnus-tmp-header)) ?s)
783 (?M ,(macroexpand '(mail-header-id gnus-tmp-header)) ?s) 840 (?M ,(macroexpand '(mail-header-id gnus-tmp-header)) ?s)
784 (?r ,(macroexpand '(mail-header-references gnus-tmp-header)) ?s) 841 (?r ,(macroexpand '(mail-header-references gnus-tmp-header)) ?s)
785 (?c (or (mail-header-chars gnus-tmp-header) 0) ?d) 842 (?c (or (mail-header-chars gnus-tmp-header) 0) ?d)
@@ -827,6 +884,7 @@ variable (string, integer, character, etc).")
827 (?d (length gnus-newsgroup-dormant) ?d) 884 (?d (length gnus-newsgroup-dormant) ?d)
828 (?t (length gnus-newsgroup-marked) ?d) 885 (?t (length gnus-newsgroup-marked) ?d)
829 (?r (length gnus-newsgroup-reads) ?d) 886 (?r (length gnus-newsgroup-reads) ?d)
887 (?z (gnus-summary-article-score gnus-tmp-article-number) ?d)
830 (?E gnus-newsgroup-expunged-tally ?d) 888 (?E gnus-newsgroup-expunged-tally ?d)
831 (?s (gnus-current-score-file-nondirectory) ?s))) 889 (?s (gnus-current-score-file-nondirectory) ?s)))
832 890
@@ -884,6 +942,15 @@ variable (string, integer, character, etc).")
884(defvar gnus-newsgroup-processable nil 942(defvar gnus-newsgroup-processable nil
885 "List of articles in the current newsgroup that can be processed.") 943 "List of articles in the current newsgroup that can be processed.")
886 944
945(defvar gnus-newsgroup-downloadable nil
946 "List of articles in the current newsgroup that can be processed.")
947
948(defvar gnus-newsgroup-undownloaded nil
949 "List of articles in the current newsgroup that haven't been downloaded..")
950
951(defvar gnus-newsgroup-unsendable nil
952 "List of articles in the current newsgroup that won't be sent.")
953
887(defvar gnus-newsgroup-bookmarks nil 954(defvar gnus-newsgroup-bookmarks nil
888 "List of articles in the current newsgroup that have bookmarks.") 955 "List of articles in the current newsgroup that have bookmarks.")
889 956
@@ -923,6 +990,8 @@ variable (string, integer, character, etc).")
923 gnus-newsgroup-reads gnus-newsgroup-saved 990 gnus-newsgroup-reads gnus-newsgroup-saved
924 gnus-newsgroup-replied gnus-newsgroup-expirable 991 gnus-newsgroup-replied gnus-newsgroup-expirable
925 gnus-newsgroup-processable gnus-newsgroup-killed 992 gnus-newsgroup-processable gnus-newsgroup-killed
993 gnus-newsgroup-downloadable gnus-newsgroup-undownloaded
994 gnus-newsgroup-unsendable
926 gnus-newsgroup-bookmarks gnus-newsgroup-dormant 995 gnus-newsgroup-bookmarks gnus-newsgroup-dormant
927 gnus-newsgroup-headers gnus-newsgroup-threads 996 gnus-newsgroup-headers gnus-newsgroup-threads
928 gnus-newsgroup-prepared gnus-summary-highlight-line-function 997 gnus-newsgroup-prepared gnus-summary-highlight-line-function
@@ -949,6 +1018,22 @@ variable (string, integer, character, etc).")
949 1018
950;; Subject simplification. 1019;; Subject simplification.
951 1020
1021(defun gnus-simplify-whitespace (str)
1022 "Remove excessive whitespace."
1023 (let ((mystr str))
1024 ;; Multiple spaces.
1025 (while (string-match "[ \t][ \t]+" mystr)
1026 (setq mystr (concat (substring mystr 0 (match-beginning 0))
1027 " "
1028 (substring mystr (match-end 0)))))
1029 ;; Leading spaces.
1030 (when (string-match "^[ \t]+" mystr)
1031 (setq mystr (substring mystr (match-end 0))))
1032 ;; Trailing spaces.
1033 (when (string-match "[ \t]+$" mystr)
1034 (setq mystr (substring mystr 0 (match-beginning 0))))
1035 mystr))
1036
952(defsubst gnus-simplify-subject-re (subject) 1037(defsubst gnus-simplify-subject-re (subject)
953 "Remove \"Re:\" from subject lines." 1038 "Remove \"Re:\" from subject lines."
954 (if (string-match "^[Rr][Ee]: *" subject) 1039 (if (string-match "^[Rr][Ee]: *" subject)
@@ -1012,10 +1097,14 @@ gnus-simplify-subject-fuzzy-regexp."
1012 1097
1013(defun gnus-simplify-subject-fuzzy (subject) 1098(defun gnus-simplify-subject-fuzzy (subject)
1014 "Simplify a subject string fuzzily. 1099 "Simplify a subject string fuzzily.
1015See gnus-simplify-buffer-fuzzy for details." 1100See `gnus-simplify-buffer-fuzzy' for details."
1016 (save-excursion 1101 (save-excursion
1017 (gnus-set-work-buffer) 1102 (gnus-set-work-buffer)
1018 (let ((case-fold-search t)) 1103 (let ((case-fold-search t))
1104 ;; Remove uninteresting prefixes.
1105 (when (and gnus-simplify-ignored-prefixes
1106 (string-match gnus-simplify-ignored-prefixes subject))
1107 (setq subject (substring subject (match-end 0))))
1019 (insert subject) 1108 (insert subject)
1020 (inline (gnus-simplify-buffer-fuzzy)) 1109 (inline (gnus-simplify-buffer-fuzzy))
1021 (buffer-string)))) 1110 (buffer-string))))
@@ -1023,6 +1112,8 @@ See gnus-simplify-buffer-fuzzy for details."
1023(defsubst gnus-simplify-subject-fully (subject) 1112(defsubst gnus-simplify-subject-fully (subject)
1024 "Simplify a subject string according to gnus-summary-gather-subject-limit." 1113 "Simplify a subject string according to gnus-summary-gather-subject-limit."
1025 (cond 1114 (cond
1115 (gnus-simplify-subject-functions
1116 (gnus-map-function gnus-simplify-subject-functions subject))
1026 ((null gnus-summary-gather-subject-limit) 1117 ((null gnus-summary-gather-subject-limit)
1027 (gnus-simplify-subject-re subject)) 1118 (gnus-simplify-subject-re subject))
1028 ((eq gnus-summary-gather-subject-limit 'fuzzy) 1119 ((eq gnus-summary-gather-subject-limit 'fuzzy)
@@ -1034,8 +1125,9 @@ See gnus-simplify-buffer-fuzzy for details."
1034 subject))) 1125 subject)))
1035 1126
1036(defsubst gnus-subject-equal (s1 s2 &optional simple-first) 1127(defsubst gnus-subject-equal (s1 s2 &optional simple-first)
1037 "Check whether two subjects are equal. If optional argument 1128 "Check whether two subjects are equal.
1038simple-first is t, first argument is already simplified." 1129If optional argument simple-first is t, first argument is already
1130simplified."
1039 (cond 1131 (cond
1040 ((null simple-first) 1132 ((null simple-first)
1041 (equal (gnus-simplify-subject-fully s1) 1133 (equal (gnus-simplify-subject-fully s1)
@@ -1064,7 +1156,9 @@ increase the score of each group you read."
1064 " " gnus-summary-next-page 1156 " " gnus-summary-next-page
1065 "\177" gnus-summary-prev-page 1157 "\177" gnus-summary-prev-page
1066 [delete] gnus-summary-prev-page 1158 [delete] gnus-summary-prev-page
1159 [backspace] gnus-summary-prev-page
1067 "\r" gnus-summary-scroll-up 1160 "\r" gnus-summary-scroll-up
1161 "\M-\r" gnus-summary-scroll-down
1068 "n" gnus-summary-next-unread-article 1162 "n" gnus-summary-next-unread-article
1069 "p" gnus-summary-prev-unread-article 1163 "p" gnus-summary-prev-unread-article
1070 "N" gnus-summary-next-article 1164 "N" gnus-summary-next-article
@@ -1149,6 +1243,7 @@ increase the score of each group you read."
1149 "\C-c\C-v\C-v" gnus-uu-decode-uu-view 1243 "\C-c\C-v\C-v" gnus-uu-decode-uu-view
1150 "\C-d" gnus-summary-enter-digest-group 1244 "\C-d" gnus-summary-enter-digest-group
1151 "\M-\C-d" gnus-summary-read-document 1245 "\M-\C-d" gnus-summary-read-document
1246 "\M-\C-e" gnus-summary-edit-parameters
1152 "\C-c\C-b" gnus-bug 1247 "\C-c\C-b" gnus-bug
1153 "*" gnus-cache-enter-article 1248 "*" gnus-cache-enter-article
1154 "\M-*" gnus-cache-remove-article 1249 "\M-*" gnus-cache-remove-article
@@ -1156,6 +1251,8 @@ increase the score of each group you read."
1156 "\C-l" gnus-recenter 1251 "\C-l" gnus-recenter
1157 "I" gnus-summary-increase-score 1252 "I" gnus-summary-increase-score
1158 "L" gnus-summary-lower-score 1253 "L" gnus-summary-lower-score
1254 "\M-i" gnus-symbolic-argument
1255 "h" gnus-summary-select-article-buffer
1159 1256
1160 "V" gnus-summary-score-map 1257 "V" gnus-summary-score-map
1161 "X" gnus-uu-extract-map 1258 "X" gnus-uu-extract-map
@@ -1199,7 +1296,9 @@ increase the score of each group you read."
1199 "u" gnus-summary-limit-to-unread 1296 "u" gnus-summary-limit-to-unread
1200 "m" gnus-summary-limit-to-marks 1297 "m" gnus-summary-limit-to-marks
1201 "v" gnus-summary-limit-to-score 1298 "v" gnus-summary-limit-to-score
1299 "*" gnus-summary-limit-include-cached
1202 "D" gnus-summary-limit-include-dormant 1300 "D" gnus-summary-limit-include-dormant
1301 "T" gnus-summary-limit-include-thread
1203 "d" gnus-summary-limit-exclude-dormant 1302 "d" gnus-summary-limit-exclude-dormant
1204 "t" gnus-summary-limit-to-age 1303 "t" gnus-summary-limit-to-age
1205 "E" gnus-summary-limit-include-expunged 1304 "E" gnus-summary-limit-include-expunged
@@ -1265,6 +1364,7 @@ increase the score of each group you read."
1265 [delete] gnus-summary-prev-page 1364 [delete] gnus-summary-prev-page
1266 "p" gnus-summary-prev-page 1365 "p" gnus-summary-prev-page
1267 "\r" gnus-summary-scroll-up 1366 "\r" gnus-summary-scroll-up
1367 "\M-\r" gnus-summary-scroll-down
1268 "<" gnus-summary-beginning-of-article 1368 "<" gnus-summary-beginning-of-article
1269 ">" gnus-summary-end-of-article 1369 ">" gnus-summary-end-of-article
1270 "b" gnus-summary-beginning-of-article 1370 "b" gnus-summary-beginning-of-article
@@ -1272,6 +1372,7 @@ increase the score of each group you read."
1272 "^" gnus-summary-refer-parent-article 1372 "^" gnus-summary-refer-parent-article
1273 "r" gnus-summary-refer-parent-article 1373 "r" gnus-summary-refer-parent-article
1274 "R" gnus-summary-refer-references 1374 "R" gnus-summary-refer-references
1375 "T" gnus-summary-refer-thread
1275 "g" gnus-summary-show-article 1376 "g" gnus-summary-show-article
1276 "s" gnus-summary-isearch-article 1377 "s" gnus-summary-isearch-article
1277 "P" gnus-summary-print-article) 1378 "P" gnus-summary-print-article)
@@ -1290,7 +1391,8 @@ increase the score of each group you read."
1290 "t" gnus-article-hide-headers 1391 "t" gnus-article-hide-headers
1291 "v" gnus-summary-verbose-headers 1392 "v" gnus-summary-verbose-headers
1292 "m" gnus-summary-toggle-mime 1393 "m" gnus-summary-toggle-mime
1293 "h" gnus-article-treat-html) 1394 "h" gnus-article-treat-html
1395 "d" gnus-article-treat-dumbquotes)
1294 1396
1295 (gnus-define-keys (gnus-summary-wash-hide-map "W" gnus-summary-wash-map) 1397 (gnus-define-keys (gnus-summary-wash-hide-map "W" gnus-summary-wash-map)
1296 "a" gnus-article-hide 1398 "a" gnus-article-hide
@@ -1298,6 +1400,7 @@ increase the score of each group you read."
1298 "b" gnus-article-hide-boring-headers 1400 "b" gnus-article-hide-boring-headers
1299 "s" gnus-article-hide-signature 1401 "s" gnus-article-hide-signature
1300 "c" gnus-article-hide-citation 1402 "c" gnus-article-hide-citation
1403 "C" gnus-article-hide-citation-in-followups
1301 "p" gnus-article-hide-pgp 1404 "p" gnus-article-hide-pgp
1302 "P" gnus-article-hide-pem 1405 "P" gnus-article-hide-pem
1303 "\C-c" gnus-article-hide-citation-maybe) 1406 "\C-c" gnus-article-hide-citation-maybe)
@@ -1314,6 +1417,7 @@ increase the score of each group you read."
1314 "l" gnus-article-date-local 1417 "l" gnus-article-date-local
1315 "e" gnus-article-date-lapsed 1418 "e" gnus-article-date-lapsed
1316 "o" gnus-article-date-original 1419 "o" gnus-article-date-original
1420 "i" gnus-article-date-iso8601
1317 "s" gnus-article-date-user) 1421 "s" gnus-article-date-user)
1318 1422
1319 (gnus-define-keys (gnus-summary-wash-empty-map "E" gnus-summary-wash-map) 1423 (gnus-define-keys (gnus-summary-wash-empty-map "E" gnus-summary-wash-map)
@@ -1321,6 +1425,7 @@ increase the score of each group you read."
1321 "l" gnus-article-strip-leading-blank-lines 1425 "l" gnus-article-strip-leading-blank-lines
1322 "m" gnus-article-strip-multiple-blank-lines 1426 "m" gnus-article-strip-multiple-blank-lines
1323 "a" gnus-article-strip-blank-lines 1427 "a" gnus-article-strip-blank-lines
1428 "A" gnus-article-strip-all-blank-lines
1324 "s" gnus-article-strip-leading-space) 1429 "s" gnus-article-strip-leading-space)
1325 1430
1326 (gnus-define-keys (gnus-summary-help-map "H" gnus-summary-mode-map) 1431 (gnus-define-keys (gnus-summary-help-map "H" gnus-summary-mode-map)
@@ -1341,6 +1446,7 @@ increase the score of each group you read."
1341 "c" gnus-summary-copy-article 1446 "c" gnus-summary-copy-article
1342 "B" gnus-summary-crosspost-article 1447 "B" gnus-summary-crosspost-article
1343 "q" gnus-summary-respool-query 1448 "q" gnus-summary-respool-query
1449 "t" gnus-summary-respool-trace
1344 "i" gnus-summary-import-article 1450 "i" gnus-summary-import-article
1345 "p" gnus-summary-article-posted-p) 1451 "p" gnus-summary-article-posted-p)
1346 1452
@@ -1389,208 +1495,112 @@ increase the score of each group you read."
1389 ["Increase score..." gnus-summary-increase-score t] 1495 ["Increase score..." gnus-summary-increase-score t]
1390 ["Lower score..." gnus-summary-lower-score t])))) 1496 ["Lower score..." gnus-summary-lower-score t]))))
1391 1497
1392 '(("Default header" 1498 ;; Define both the Article menu in the summary buffer and the equivalent
1393 ["Ask" (gnus-score-set-default 'gnus-score-default-header nil) 1499 ;; Commands menu in the article buffer here for consistency.
1394 :style radio 1500 (let ((innards
1395 :selected (null gnus-score-default-header)] 1501 '(("Hide"
1396 ["From" (gnus-score-set-default 'gnus-score-default-header 'a) 1502 ["All" gnus-article-hide t]
1397 :style radio 1503 ["Headers" gnus-article-hide-headers t]
1398 :selected (eq gnus-score-default-header 'a)] 1504 ["Signature" gnus-article-hide-signature t]
1399 ["Subject" (gnus-score-set-default 'gnus-score-default-header 's) 1505 ["Citation" gnus-article-hide-citation t]
1400 :style radio 1506 ["PGP" gnus-article-hide-pgp t]
1401 :selected (eq gnus-score-default-header 's)] 1507 ["Boring headers" gnus-article-hide-boring-headers t])
1402 ["Article body" 1508 ("Highlight"
1403 (gnus-score-set-default 'gnus-score-default-header 'b) 1509 ["All" gnus-article-highlight t]
1404 :style radio 1510 ["Headers" gnus-article-highlight-headers t]
1405 :selected (eq gnus-score-default-header 'b )] 1511 ["Signature" gnus-article-highlight-signature t]
1406 ["All headers" 1512 ["Citation" gnus-article-highlight-citation t])
1407 (gnus-score-set-default 'gnus-score-default-header 'h) 1513 ("Date"
1408 :style radio 1514 ["Local" gnus-article-date-local t]
1409 :selected (eq gnus-score-default-header 'h )] 1515 ["ISO8601" gnus-article-date-iso8601 t]
1410 ["Message-ID" (gnus-score-set-default 'gnus-score-default-header 'i) 1516 ["UT" gnus-article-date-ut t]
1411 :style radio 1517 ["Original" gnus-article-date-original t]
1412 :selected (eq gnus-score-default-header 'i )] 1518 ["Lapsed" gnus-article-date-lapsed t]
1413 ["Thread" (gnus-score-set-default 'gnus-score-default-header 't) 1519 ["User-defined" gnus-article-date-user t])
1414 :style radio 1520 ("Washing"
1415 :selected (eq gnus-score-default-header 't )] 1521 ("Remove Blanks"
1416 ["Crossposting" 1522 ["Leading" gnus-article-strip-leading-blank-lines t]
1417 (gnus-score-set-default 'gnus-score-default-header 'x) 1523 ["Multiple" gnus-article-strip-multiple-blank-lines t]
1418 :style radio 1524 ["Trailing" gnus-article-remove-trailing-blank-lines t]
1419 :selected (eq gnus-score-default-header 'x )] 1525 ["All of the above" gnus-article-strip-blank-lines t]
1420 ["Lines" (gnus-score-set-default 'gnus-score-default-header 'l) 1526 ["All" gnus-article-strip-all-blank-lines t]
1421 :style radio 1527 ["Leading space" gnus-article-strip-leading-space t])
1422 :selected (eq gnus-score-default-header 'l )] 1528 ["Overstrike" gnus-article-treat-overstrike t]
1423 ["Date" (gnus-score-set-default 'gnus-score-default-header 'd) 1529 ["Dumb quotes" gnus-article-treat-dumbquotes t]
1424 :style radio 1530 ["Emphasis" gnus-article-emphasize t]
1425 :selected (eq gnus-score-default-header 'd )] 1531 ["Word wrap" gnus-article-fill-cited-article t]
1426 ["Followups to author" 1532 ["CR" gnus-article-remove-cr t]
1427 (gnus-score-set-default 'gnus-score-default-header 'f) 1533 ["Show X-Face" gnus-article-display-x-face t]
1428 :style radio 1534 ["Quoted-Printable" gnus-article-de-quoted-unreadable t]
1429 :selected (eq gnus-score-default-header 'f )]) 1535 ["UnHTMLize" gnus-article-treat-html t]
1430 ("Default type" 1536 ["Rot 13" gnus-summary-caesar-message t]
1431 ["Ask" (gnus-score-set-default 'gnus-score-default-type nil) 1537 ["Unix pipe" gnus-summary-pipe-message t]
1432 :style radio 1538 ["Add buttons" gnus-article-add-buttons t]
1433 :selected (null gnus-score-default-type)] 1539 ["Add buttons to head" gnus-article-add-buttons-to-head t]
1434 ;; The `:active' key is commented out in the following, 1540 ["Stop page breaking" gnus-summary-stop-page-breaking t]
1435 ;; because the GNU Emacs hack to support radio buttons use 1541 ["Toggle MIME" gnus-summary-toggle-mime t]
1436 ;; active to indicate which button is selected. 1542 ["Verbose header" gnus-summary-verbose-headers t]
1437 ["Substring" (gnus-score-set-default 'gnus-score-default-type 's) 1543 ["Toggle header" gnus-summary-toggle-header t])
1438 :style radio 1544 ("Output"
1439 ;; :active (not (memq gnus-score-default-header '(l d))) 1545 ["Save in default format" gnus-summary-save-article t]
1440 :selected (eq gnus-score-default-type 's)] 1546 ["Save in file" gnus-summary-save-article-file t]
1441 ["Regexp" (gnus-score-set-default 'gnus-score-default-type 'r) 1547 ["Save in Unix mail format" gnus-summary-save-article-mail t]
1442 :style radio 1548 ["Save in MH folder" gnus-summary-save-article-folder t]
1443 ;; :active (not (memq gnus-score-default-header '(l d))) 1549 ["Save in VM folder" gnus-summary-save-article-vm t]
1444 :selected (eq gnus-score-default-type 'r)] 1550 ["Save in RMAIL mbox" gnus-summary-save-article-rmail t]
1445 ["Exact" (gnus-score-set-default 'gnus-score-default-type 'e) 1551 ["Save body in file" gnus-summary-save-article-body-file t]
1446 :style radio 1552 ["Pipe through a filter" gnus-summary-pipe-output t]
1447 ;; :active (not (memq gnus-score-default-header '(l d))) 1553 ["Add to SOUP packet" gnus-soup-add-article t]
1448 :selected (eq gnus-score-default-type 'e)] 1554 ["Print" gnus-summary-print-article t])
1449 ["Fuzzy" (gnus-score-set-default 'gnus-score-default-type 'f) 1555 ("Backend"
1450 :style radio 1556 ["Respool article..." gnus-summary-respool-article t]
1451 ;; :active (not (memq gnus-score-default-header '(l d))) 1557 ["Move article..." gnus-summary-move-article
1452 :selected (eq gnus-score-default-type 'f)] 1558 (gnus-check-backend-function
1453 ["Before date" (gnus-score-set-default 'gnus-score-default-type 'b) 1559 'request-move-article gnus-newsgroup-name)]
1454 :style radio 1560 ["Copy article..." gnus-summary-copy-article t]
1455 ;; :active (eq (gnus-score-default-header 'd)) 1561 ["Crosspost article..." gnus-summary-crosspost-article
1456 :selected (eq gnus-score-default-type 'b)] 1562 (gnus-check-backend-function
1457 ["At date" (gnus-score-set-default 'gnus-score-default-type 'n) 1563 'request-replace-article gnus-newsgroup-name)]
1458 :style radio 1564 ["Import file..." gnus-summary-import-article t]
1459 ;; :active (eq (gnus-score-default-header 'd)) 1565 ["Check if posted" gnus-summary-article-posted-p t]
1460 :selected (eq gnus-score-default-type 'n)] 1566 ["Edit article" gnus-summary-edit-article
1461 ["After date" (gnus-score-set-default 'gnus-score-default-type 'a) 1567 (not (gnus-group-read-only-p))]
1462 :style radio 1568 ["Delete article" gnus-summary-delete-article
1463 ;; :active (eq (gnus-score-default-header 'd)) 1569 (gnus-check-backend-function
1464 :selected (eq gnus-score-default-type 'a)] 1570 'request-expire-articles gnus-newsgroup-name)]
1465 ["Less than number" 1571 ["Query respool" gnus-summary-respool-query t]
1466 (gnus-score-set-default 'gnus-score-default-type '<) 1572 ["Trace respool" gnus-summary-respool-trace t]
1467 :style radio 1573 ["Delete expirable articles" gnus-summary-expire-articles-now
1468 ;; :active (eq (gnus-score-default-header 'l)) 1574 (gnus-check-backend-function
1469 :selected (eq gnus-score-default-type '<)] 1575 'request-expire-articles gnus-newsgroup-name)])
1470 ["Equal to number" 1576 ("Extract"
1471 (gnus-score-set-default 'gnus-score-default-type '=) 1577 ["Uudecode" gnus-uu-decode-uu t]
1472 :style radio 1578 ["Uudecode and save" gnus-uu-decode-uu-and-save t]
1473 ;; :active (eq (gnus-score-default-header 'l)) 1579 ["Unshar" gnus-uu-decode-unshar t]
1474 :selected (eq gnus-score-default-type '=)] 1580 ["Unshar and save" gnus-uu-decode-unshar-and-save t]
1475 ["Greater than number" 1581 ["Save" gnus-uu-decode-save t]
1476 (gnus-score-set-default 'gnus-score-default-type '>) 1582 ["Binhex" gnus-uu-decode-binhex t]
1477 :style radio 1583 ["Postscript" gnus-uu-decode-postscript t])
1478 ;; :active (eq (gnus-score-default-header 'l)) 1584 ("Cache"
1479 :selected (eq gnus-score-default-type '>)]) 1585 ["Enter article" gnus-cache-enter-article t]
1480 ["Default fold" gnus-score-default-fold-toggle 1586 ["Remove article" gnus-cache-remove-article t])
1481 :style toggle 1587 ["Select article buffer" gnus-summary-select-article-buffer t]
1482 :selected gnus-score-default-fold] 1588 ["Enter digest buffer" gnus-summary-enter-digest-group t]
1483 ("Default duration" 1589 ["Isearch article..." gnus-summary-isearch-article t]
1484 ["Ask" (gnus-score-set-default 'gnus-score-default-duration nil) 1590 ["Beginning of the article" gnus-summary-beginning-of-article t]
1485 :style radio 1591 ["End of the article" gnus-summary-end-of-article t]
1486 :selected (null gnus-score-default-duration)] 1592 ["Fetch parent of article" gnus-summary-refer-parent-article t]
1487 ["Permanent" 1593 ["Fetch referenced articles" gnus-summary-refer-references t]
1488 (gnus-score-set-default 'gnus-score-default-duration 'p) 1594 ["Fetch current thread" gnus-summary-refer-thread t]
1489 :style radio 1595 ["Fetch article with id..." gnus-summary-refer-article t]
1490 :selected (eq gnus-score-default-duration 'p)] 1596 ["Redisplay" gnus-summary-show-article t])))
1491 ["Temporary" 1597 (easy-menu-define
1492 (gnus-score-set-default 'gnus-score-default-duration 't) 1598 gnus-summary-article-menu gnus-summary-mode-map ""
1493 :style radio 1599 (cons "Article" innards))
1494 :selected (eq gnus-score-default-duration 't)] 1600
1495 ["Immediate" 1601 (easy-menu-define
1496 (gnus-score-set-default 'gnus-score-default-duration 'i) 1602 gnus-article-commands-menu gnus-article-mode-map ""
1497 :style radio 1603 (cons "Commands" innards)))
1498 :selected (eq gnus-score-default-duration 'i)]))
1499
1500 (easy-menu-define
1501 gnus-summary-article-menu gnus-summary-mode-map ""
1502 '("Article"
1503 ("Hide"
1504 ["All" gnus-article-hide t]
1505 ["Headers" gnus-article-hide-headers t]
1506 ["Signature" gnus-article-hide-signature t]
1507 ["Citation" gnus-article-hide-citation t]
1508 ["PGP" gnus-article-hide-pgp t]
1509 ["Boring headers" gnus-article-hide-boring-headers t])
1510 ("Highlight"
1511 ["All" gnus-article-highlight t]
1512 ["Headers" gnus-article-highlight-headers t]
1513 ["Signature" gnus-article-highlight-signature t]
1514 ["Citation" gnus-article-highlight-citation t])
1515 ("Date"
1516 ["Local" gnus-article-date-local t]
1517 ["UT" gnus-article-date-ut t]
1518 ["Original" gnus-article-date-original t]
1519 ["Lapsed" gnus-article-date-lapsed t]
1520 ["User-defined" gnus-article-date-user t])
1521 ("Washing"
1522 ("Remove Blanks"
1523 ["Leading" gnus-article-strip-leading-blank-lines t]
1524 ["Multiple" gnus-article-strip-multiple-blank-lines t]
1525 ["Trailing" gnus-article-remove-trailing-blank-lines t]
1526 ["All of the above" gnus-article-strip-blank-lines t]
1527 ["Leading space" gnus-article-strip-leading-space t])
1528 ["Overstrike" gnus-article-treat-overstrike t]
1529 ["Emphasis" gnus-article-emphasize t]
1530 ["Word wrap" gnus-article-fill-cited-article t]
1531 ["CR" gnus-article-remove-cr t]
1532 ["Show X-Face" gnus-article-display-x-face t]
1533 ["Quoted-Printable" gnus-article-de-quoted-unreadable t]
1534 ["UnHTMLize" gnus-article-treat-html t]
1535 ["Rot 13" gnus-summary-caesar-message t]
1536 ["Unix pipe" gnus-summary-pipe-message t]
1537 ["Add buttons" gnus-article-add-buttons t]
1538 ["Add buttons to head" gnus-article-add-buttons-to-head t]
1539 ["Stop page breaking" gnus-summary-stop-page-breaking t]
1540 ["Toggle MIME" gnus-summary-toggle-mime t]
1541 ["Verbose header" gnus-summary-verbose-headers t]
1542 ["Toggle header" gnus-summary-toggle-header t])
1543 ("Output"
1544 ["Save in default format" gnus-summary-save-article t]
1545 ["Save in file" gnus-summary-save-article-file t]
1546 ["Save in Unix mail format" gnus-summary-save-article-mail t]
1547 ["Write to file" gnus-summary-write-article-mail t]
1548 ["Save in MH folder" gnus-summary-save-article-folder t]
1549 ["Save in VM folder" gnus-summary-save-article-vm t]
1550 ["Save in RMAIL mbox" gnus-summary-save-article-rmail t]
1551 ["Save body in file" gnus-summary-save-article-body-file t]
1552 ["Pipe through a filter" gnus-summary-pipe-output t]
1553 ["Add to SOUP packet" gnus-soup-add-article t]
1554 ["Print" gnus-summary-print-article t])
1555 ("Backend"
1556 ["Respool article..." gnus-summary-respool-article t]
1557 ["Move article..." gnus-summary-move-article
1558 (gnus-check-backend-function
1559 'request-move-article gnus-newsgroup-name)]
1560 ["Copy article..." gnus-summary-copy-article t]
1561 ["Crosspost article..." gnus-summary-crosspost-article
1562 (gnus-check-backend-function
1563 'request-replace-article gnus-newsgroup-name)]
1564 ["Import file..." gnus-summary-import-article t]
1565 ["Check if posted" gnus-summary-article-posted-p t]
1566 ["Edit article" gnus-summary-edit-article
1567 (not (gnus-group-read-only-p))]
1568 ["Delete article" gnus-summary-delete-article
1569 (gnus-check-backend-function
1570 'request-expire-articles gnus-newsgroup-name)]
1571 ["Query respool" gnus-summary-respool-query t]
1572 ["Delete expirable articles" gnus-summary-expire-articles-now
1573 (gnus-check-backend-function
1574 'request-expire-articles gnus-newsgroup-name)])
1575 ("Extract"
1576 ["Uudecode" gnus-uu-decode-uu t]
1577 ["Uudecode and save" gnus-uu-decode-uu-and-save t]
1578 ["Unshar" gnus-uu-decode-unshar t]
1579 ["Unshar and save" gnus-uu-decode-unshar-and-save t]
1580 ["Save" gnus-uu-decode-save t]
1581 ["Binhex" gnus-uu-decode-binhex t]
1582 ["Postscript" gnus-uu-decode-postscript t])
1583 ("Cache"
1584 ["Enter article" gnus-cache-enter-article t]
1585 ["Remove article" gnus-cache-remove-article t])
1586 ["Enter digest buffer" gnus-summary-enter-digest-group t]
1587 ["Isearch article..." gnus-summary-isearch-article t]
1588 ["Beginning of the article" gnus-summary-beginning-of-article t]
1589 ["End of the article" gnus-summary-end-of-article t]
1590 ["Fetch parent of article" gnus-summary-refer-parent-article t]
1591 ["Fetch referenced articles" gnus-summary-refer-references t]
1592 ["Fetch article with id..." gnus-summary-refer-article t]
1593 ["Redisplay" gnus-summary-show-article t]))
1594 1604
1595 (easy-menu-define 1605 (easy-menu-define
1596 gnus-summary-thread-menu gnus-summary-mode-map "" 1606 gnus-summary-thread-menu gnus-summary-mode-map ""
@@ -1681,7 +1691,9 @@ increase the score of each group you read."
1681 ["Mark above" gnus-uu-mark-over t] 1691 ["Mark above" gnus-uu-mark-over t]
1682 ["Mark series" gnus-uu-mark-series t] 1692 ["Mark series" gnus-uu-mark-series t]
1683 ["Mark region" gnus-uu-mark-region t] 1693 ["Mark region" gnus-uu-mark-region t]
1694 ["Unmark region" gnus-uu-unmark-region t]
1684 ["Mark by regexp..." gnus-uu-mark-by-regexp t] 1695 ["Mark by regexp..." gnus-uu-mark-by-regexp t]
1696 ["Unmark by regexp..." gnus-uu-unmark-by-regexp t]
1685 ["Mark all" gnus-uu-mark-all t] 1697 ["Mark all" gnus-uu-mark-all t]
1686 ["Mark buffer" gnus-uu-mark-buffer t] 1698 ["Mark buffer" gnus-uu-mark-buffer t]
1687 ["Mark sparse" gnus-uu-mark-sparse t] 1699 ["Mark sparse" gnus-uu-mark-sparse t]
@@ -1740,9 +1752,11 @@ increase the score of each group you read."
1740 'request-expire-articles gnus-newsgroup-name)] 1752 'request-expire-articles gnus-newsgroup-name)]
1741 ["Edit local kill file" gnus-summary-edit-local-kill t] 1753 ["Edit local kill file" gnus-summary-edit-local-kill t]
1742 ["Edit main kill file" gnus-summary-edit-global-kill t] 1754 ["Edit main kill file" gnus-summary-edit-global-kill t]
1755 ["Edit group parameters" gnus-summary-edit-parameters t]
1756 ["Send a bug report" gnus-bug t]
1743 ("Exit" 1757 ("Exit"
1744 ["Catchup and exit" gnus-summary-catchup-and-exit t] 1758 ["Catchup and exit" gnus-summary-catchup-and-exit t]
1745 ["Catchup all and exit" gnus-summary-catchup-and-exit t] 1759 ["Catchup all and exit" gnus-summary-catchup-all-and-exit t]
1746 ["Catchup and goto next" gnus-summary-catchup-and-goto-next-group t] 1760 ["Catchup and goto next" gnus-summary-catchup-and-goto-next-group t]
1747 ["Exit group" gnus-summary-exit t] 1761 ["Exit group" gnus-summary-exit t]
1748 ["Exit group without updating" gnus-summary-exit-no-update t] 1762 ["Exit group without updating" gnus-summary-exit-no-update t]
@@ -1752,7 +1766,7 @@ increase the score of each group you read."
1752 ["Rescan group" gnus-summary-rescan-group t] 1766 ["Rescan group" gnus-summary-rescan-group t]
1753 ["Update dribble" gnus-summary-save-newsrc t]))) 1767 ["Update dribble" gnus-summary-save-newsrc t])))
1754 1768
1755 (run-hooks 'gnus-summary-menu-hook))) 1769 (gnus-run-hooks 'gnus-summary-menu-hook)))
1756 1770
1757(defun gnus-score-set-default (var value) 1771(defun gnus-score-set-default (var value)
1758 "A version of set that updates the GNU Emacs menu-bar." 1772 "A version of set that updates the GNU Emacs menu-bar."
@@ -1880,10 +1894,14 @@ The following commands are available:
1880 (setq gnus-newsgroup-name group) 1894 (setq gnus-newsgroup-name group)
1881 (make-local-variable 'gnus-summary-line-format) 1895 (make-local-variable 'gnus-summary-line-format)
1882 (make-local-variable 'gnus-summary-line-format-spec) 1896 (make-local-variable 'gnus-summary-line-format-spec)
1897 (make-local-variable 'gnus-summary-dummy-line-format)
1898 (make-local-variable 'gnus-summary-dummy-line-format-spec)
1883 (make-local-variable 'gnus-summary-mark-positions) 1899 (make-local-variable 'gnus-summary-mark-positions)
1884 (make-local-hook 'post-command-hook) 1900 (make-local-hook 'post-command-hook)
1885 (add-hook 'post-command-hook 'gnus-clear-inboxes-moved nil t) 1901 (add-hook 'post-command-hook 'gnus-clear-inboxes-moved nil t)
1886 (run-hooks 'gnus-summary-mode-hook) 1902 (make-local-hook 'pre-command-hook)
1903 (add-hook 'pre-command-hook 'gnus-set-global-variables nil t)
1904 (gnus-run-hooks 'gnus-summary-mode-hook)
1887 (gnus-update-format-specifications nil 'summary 'summary-mode 'summary-dummy) 1905 (gnus-update-format-specifications nil 'summary 'summary-mode 'summary-dummy)
1888 (gnus-update-summary-mark-positions)) 1906 (gnus-update-summary-mark-positions))
1889 1907
@@ -1977,21 +1995,26 @@ The following commands are available:
1977 (when list 1995 (when list
1978 (let ((data (and after-article (gnus-data-find-list after-article))) 1996 (let ((data (and after-article (gnus-data-find-list after-article)))
1979 (ilist list)) 1997 (ilist list))
1980 (or data (not after-article) (error "No such article: %d" after-article)) 1998 (if (not (or data
1981 ;; Find the last element in the list to be spliced into the main 1999 after-article))
1982 ;; list. 2000 (let ((odata gnus-newsgroup-data))
1983 (while (cdr list) 2001 (setq gnus-newsgroup-data (nconc list gnus-newsgroup-data))
1984 (setq list (cdr list)))
1985 (if (not data)
1986 (progn
1987 (setcdr list gnus-newsgroup-data)
1988 (setq gnus-newsgroup-data ilist)
1989 (when offset 2002 (when offset
1990 (gnus-data-update-list (cdr list) offset))) 2003 (gnus-data-update-list odata offset)))
1991 (setcdr list (cdr data)) 2004 ;; Find the last element in the list to be spliced into the main
1992 (setcdr data ilist) 2005 ;; list.
1993 (when offset 2006 (while (cdr list)
1994 (gnus-data-update-list (cdr list) offset))) 2007 (setq list (cdr list)))
2008 (if (not data)
2009 (progn
2010 (setcdr list gnus-newsgroup-data)
2011 (setq gnus-newsgroup-data ilist)
2012 (when offset
2013 (gnus-data-update-list (cdr list) offset)))
2014 (setcdr list (cdr data))
2015 (setcdr data ilist)
2016 (when offset
2017 (gnus-data-update-list (cdr list) offset))))
1995 (setq gnus-newsgroup-data-reverse nil)))) 2018 (setq gnus-newsgroup-data-reverse nil))))
1996 2019
1997(defun gnus-data-remove (article &optional offset) 2020(defun gnus-data-remove (article &optional offset)
@@ -2020,20 +2043,25 @@ The following commands are available:
2020 2043
2021(defun gnus-data-update-list (data offset) 2044(defun gnus-data-update-list (data offset)
2022 "Add OFFSET to the POS of all data entries in DATA." 2045 "Add OFFSET to the POS of all data entries in DATA."
2046 (setq gnus-newsgroup-data-reverse nil)
2023 (while data 2047 (while data
2024 (setcar (nthcdr 2 (car data)) (+ offset (nth 2 (car data)))) 2048 (setcar (nthcdr 2 (car data)) (+ offset (nth 2 (car data))))
2025 (setq data (cdr data)))) 2049 (setq data (cdr data))))
2026 2050
2027(defun gnus-data-compute-positions () 2051(defun gnus-data-compute-positions ()
2028 "Compute the positions of all articles." 2052 "Compute the positions of all articles."
2029 (let ((data gnus-newsgroup-data) 2053 (setq gnus-newsgroup-data-reverse nil)
2030 pos) 2054 (let ((data gnus-newsgroup-data))
2031 (while data 2055 (save-excursion
2032 (when (setq pos (text-property-any 2056 (gnus-save-hidden-threads
2033 (point-min) (point-max) 2057 (gnus-summary-show-all-threads)
2034 'gnus-number (gnus-data-number (car data)))) 2058 (goto-char (point-min))
2035 (gnus-data-set-pos (car data) (+ pos 3))) 2059 (while data
2036 (setq data (cdr data))))) 2060 (while (get-text-property (point) 'gnus-intangible)
2061 (forward-line 1))
2062 (gnus-data-set-pos (car data) (+ (point) 3))
2063 (setq data (cdr data))
2064 (forward-line 1))))))
2037 2065
2038(defun gnus-summary-article-pseudo-p (article) 2066(defun gnus-summary-article-pseudo-p (article)
2039 "Say whether this article is a pseudo article or not." 2067 "Say whether this article is a pseudo article or not."
@@ -2094,10 +2122,12 @@ article number."
2094 (gnus-summary-last-subject)))) 2122 (gnus-summary-last-subject))))
2095 2123
2096(defmacro gnus-summary-article-header (&optional number) 2124(defmacro gnus-summary-article-header (&optional number)
2125 "Return the header of article NUMBER."
2097 `(gnus-data-header (gnus-data-find 2126 `(gnus-data-header (gnus-data-find
2098 ,(or number '(gnus-summary-article-number))))) 2127 ,(or number '(gnus-summary-article-number)))))
2099 2128
2100(defmacro gnus-summary-thread-level (&optional number) 2129(defmacro gnus-summary-thread-level (&optional number)
2130 "Return the level of thread that starts with article NUMBER."
2101 `(if (and (eq gnus-summary-make-false-root 'dummy) 2131 `(if (and (eq gnus-summary-make-false-root 'dummy)
2102 (get-text-property (point) 'gnus-intangible)) 2132 (get-text-property (point) 'gnus-intangible))
2103 0 2133 0
@@ -2105,10 +2135,12 @@ article number."
2105 ,(or number '(gnus-summary-article-number)))))) 2135 ,(or number '(gnus-summary-article-number))))))
2106 2136
2107(defmacro gnus-summary-article-mark (&optional number) 2137(defmacro gnus-summary-article-mark (&optional number)
2138 "Return the mark of article NUMBER."
2108 `(gnus-data-mark (gnus-data-find 2139 `(gnus-data-mark (gnus-data-find
2109 ,(or number '(gnus-summary-article-number))))) 2140 ,(or number '(gnus-summary-article-number)))))
2110 2141
2111(defmacro gnus-summary-article-pos (&optional number) 2142(defmacro gnus-summary-article-pos (&optional number)
2143 "Return the position of the line of article NUMBER."
2112 `(gnus-data-pos (gnus-data-find 2144 `(gnus-data-pos (gnus-data-find
2113 ,(or number '(gnus-summary-article-number))))) 2145 ,(or number '(gnus-summary-article-number)))))
2114 2146
@@ -2131,6 +2163,7 @@ article number."
2131 gnus-summary-default-score 0)) 2163 gnus-summary-default-score 0))
2132 2164
2133(defun gnus-summary-article-children (&optional number) 2165(defun gnus-summary-article-children (&optional number)
2166 "Return a list of article numbers that are children of article NUMBER."
2134 (let* ((data (gnus-data-find-list (or number (gnus-summary-article-number)))) 2167 (let* ((data (gnus-data-find-list (or number (gnus-summary-article-number))))
2135 (level (gnus-data-level (car data))) 2168 (level (gnus-data-level (car data)))
2136 l children) 2169 l children)
@@ -2142,6 +2175,7 @@ article number."
2142 (nreverse children))) 2175 (nreverse children)))
2143 2176
2144(defun gnus-summary-article-parent (&optional number) 2177(defun gnus-summary-article-parent (&optional number)
2178 "Return the article number of the parent of article NUMBER."
2145 (let* ((data (gnus-data-find-list (or number (gnus-summary-article-number)) 2179 (let* ((data (gnus-data-find-list (or number (gnus-summary-article-number))
2146 (gnus-data-list t))) 2180 (gnus-data-list t)))
2147 (level (gnus-data-level (car data)))) 2181 (level (gnus-data-level (car data))))
@@ -2166,7 +2200,15 @@ This is all marks except unread, ticked, dormant, and expirable."
2166 (= mark gnus-expirable-mark)))) 2200 (= mark gnus-expirable-mark))))
2167 2201
2168(defmacro gnus-article-mark (number) 2202(defmacro gnus-article-mark (number)
2203 "Return the MARK of article NUMBER.
2204This macro should only be used when computing the mark the \"first\"
2205time; i.e., when generating the summary lines. After that,
2206`gnus-summary-article-mark' should be used to examine the
2207marks of articles."
2169 `(cond 2208 `(cond
2209 ((memq ,number gnus-newsgroup-unsendable) gnus-unsendable-mark)
2210 ((memq ,number gnus-newsgroup-undownloaded) gnus-undownloaded-mark)
2211 ((memq ,number gnus-newsgroup-downloadable) gnus-downloadable-mark)
2170 ((memq ,number gnus-newsgroup-unreads) gnus-unread-mark) 2212 ((memq ,number gnus-newsgroup-unreads) gnus-unread-mark)
2171 ((memq ,number gnus-newsgroup-marked) gnus-ticked-mark) 2213 ((memq ,number gnus-newsgroup-marked) gnus-ticked-mark)
2172 ((memq ,number gnus-newsgroup-dormant) gnus-dormant-mark) 2214 ((memq ,number gnus-newsgroup-dormant) gnus-dormant-mark)
@@ -2229,6 +2271,8 @@ This is all marks except unread, ticked, dormant, and expirable."
2229 ;; selective display). 2271 ;; selective display).
2230 (aset table ?\n nil) 2272 (aset table ?\n nil)
2231 (aset table ?\r nil) 2273 (aset table ?\r nil)
2274 ;; We keep TAB as well.
2275 (aset table ?\t nil)
2232 ;; We nix out any glyphs over 126 that are not set already. 2276 ;; We nix out any glyphs over 126 that are not set already.
2233 (let ((i 256)) 2277 (let ((i 256))
2234 (while (>= (setq i (1- i)) 127) 2278 (while (>= (setq i (1- i)) 127)
@@ -2246,8 +2290,7 @@ This is all marks except unread, ticked, dormant, and expirable."
2246 (setq gnus-summary-buffer (current-buffer)) 2290 (setq gnus-summary-buffer (current-buffer))
2247 (not gnus-newsgroup-prepared)) 2291 (not gnus-newsgroup-prepared))
2248 ;; Fix by Sudish Joseph <joseph@cis.ohio-state.edu> 2292 ;; Fix by Sudish Joseph <joseph@cis.ohio-state.edu>
2249 (setq gnus-summary-buffer (set-buffer (get-buffer-create buffer))) 2293 (setq gnus-summary-buffer (set-buffer (gnus-get-buffer-create buffer)))
2250 (gnus-add-current-to-buffer-list)
2251 (gnus-summary-mode group) 2294 (gnus-summary-mode group)
2252 (when gnus-carpal 2295 (when gnus-carpal
2253 (gnus-carpal-setup-buffer 'summary)) 2296 (gnus-carpal-setup-buffer 'summary))
@@ -2277,17 +2320,17 @@ This is all marks except unread, ticked, dormant, and expirable."
2277 (score-file gnus-current-score-file)) 2320 (score-file gnus-current-score-file))
2278 (save-excursion 2321 (save-excursion
2279 (set-buffer gnus-group-buffer) 2322 (set-buffer gnus-group-buffer)
2280 (setq gnus-newsgroup-name name) 2323 (setq gnus-newsgroup-name name
2281 (setq gnus-newsgroup-marked marked) 2324 gnus-newsgroup-marked marked
2282 (setq gnus-newsgroup-unreads unread) 2325 gnus-newsgroup-unreads unread
2283 (setq gnus-current-headers headers) 2326 gnus-current-headers headers
2284 (setq gnus-newsgroup-data data) 2327 gnus-newsgroup-data data
2285 (setq gnus-article-current gac) 2328 gnus-article-current gac
2286 (setq gnus-summary-buffer summary) 2329 gnus-summary-buffer summary
2287 (setq gnus-article-buffer article-buffer) 2330 gnus-article-buffer article-buffer
2288 (setq gnus-original-article-buffer original) 2331 gnus-original-article-buffer original
2289 (setq gnus-reffed-article-number reffed) 2332 gnus-reffed-article-number reffed
2290 (setq gnus-current-score-file score-file) 2333 gnus-current-score-file score-file)
2291 ;; The article buffer also has local variables. 2334 ;; The article buffer also has local variables.
2292 (when (gnus-buffer-live-p gnus-article-buffer) 2335 (when (gnus-buffer-live-p gnus-article-buffer)
2293 (set-buffer gnus-article-buffer) 2336 (set-buffer gnus-article-buffer)
@@ -2323,18 +2366,18 @@ This is all marks except unread, ticked, dormant, and expirable."
2323(defun gnus-update-summary-mark-positions () 2366(defun gnus-update-summary-mark-positions ()
2324 "Compute where the summary marks are to go." 2367 "Compute where the summary marks are to go."
2325 (save-excursion 2368 (save-excursion
2326 (when (and gnus-summary-buffer 2369 (when (gnus-buffer-exists-p gnus-summary-buffer)
2327 (get-buffer gnus-summary-buffer)
2328 (buffer-name (get-buffer gnus-summary-buffer)))
2329 (set-buffer gnus-summary-buffer)) 2370 (set-buffer gnus-summary-buffer))
2330 (let ((gnus-replied-mark 129) 2371 (let ((gnus-replied-mark 129)
2331 (gnus-score-below-mark 130) 2372 (gnus-score-below-mark 130)
2332 (gnus-score-over-mark 130) 2373 (gnus-score-over-mark 130)
2374 (gnus-download-mark 131)
2333 (spec gnus-summary-line-format-spec) 2375 (spec gnus-summary-line-format-spec)
2334 thread gnus-visual pos) 2376 gnus-visual pos)
2335 (save-excursion 2377 (save-excursion
2336 (gnus-set-work-buffer) 2378 (gnus-set-work-buffer)
2337 (let ((gnus-summary-line-format-spec spec)) 2379 (let ((gnus-summary-line-format-spec spec)
2380 (gnus-newsgroup-downloadable '((0 . t))))
2338 (gnus-summary-insert-line 2381 (gnus-summary-insert-line
2339 [0 "" "" "" "" "" 0 0 ""] 0 nil 128 t nil "" nil 1) 2382 [0 "" "" "" "" "" 0 0 ""] 0 nil 128 t nil "" nil 1)
2340 (goto-char (point-min)) 2383 (goto-char (point-min))
@@ -2346,6 +2389,10 @@ This is all marks except unread, ticked, dormant, and expirable."
2346 pos) 2389 pos)
2347 (goto-char (point-min)) 2390 (goto-char (point-min))
2348 (push (cons 'score (and (search-forward "\202" nil t) (- (point) 2))) 2391 (push (cons 'score (and (search-forward "\202" nil t) (- (point) 2)))
2392 pos)
2393 (goto-char (point-min))
2394 (push (cons 'download
2395 (and (search-forward "\203" nil t) (- (point) 2)))
2349 pos))) 2396 pos)))
2350 (setq gnus-summary-mark-positions pos)))) 2397 (setq gnus-summary-mark-positions pos))))
2351 2398
@@ -2369,7 +2416,7 @@ This is all marks except unread, ticked, dormant, and expirable."
2369 (if (or (null gnus-summary-default-score) 2416 (if (or (null gnus-summary-default-score)
2370 (<= (abs (- gnus-tmp-score gnus-summary-default-score)) 2417 (<= (abs (- gnus-tmp-score gnus-summary-default-score))
2371 gnus-summary-zcore-fuzz)) 2418 gnus-summary-zcore-fuzz))
2372 ? 2419 ? ;space
2373 (if (< gnus-tmp-score gnus-summary-default-score) 2420 (if (< gnus-tmp-score gnus-summary-default-score)
2374 gnus-score-below-mark gnus-score-over-mark))) 2421 gnus-score-below-mark gnus-score-over-mark)))
2375 (gnus-tmp-replied 2422 (gnus-tmp-replied
@@ -2402,13 +2449,13 @@ This is all marks except unread, ticked, dormant, and expirable."
2402 (setq gnus-tmp-name gnus-tmp-from)) 2449 (setq gnus-tmp-name gnus-tmp-from))
2403 (unless (numberp gnus-tmp-lines) 2450 (unless (numberp gnus-tmp-lines)
2404 (setq gnus-tmp-lines 0)) 2451 (setq gnus-tmp-lines 0))
2405 (gnus-put-text-property 2452 (gnus-put-text-property-excluding-characters-with-faces
2406 (point) 2453 (point)
2407 (progn (eval gnus-summary-line-format-spec) (point)) 2454 (progn (eval gnus-summary-line-format-spec) (point))
2408 'gnus-number gnus-tmp-number) 2455 'gnus-number gnus-tmp-number)
2409 (when (gnus-visual-p 'summary-highlight 'highlight) 2456 (when (gnus-visual-p 'summary-highlight 'highlight)
2410 (forward-line -1) 2457 (forward-line -1)
2411 (run-hooks 'gnus-summary-update-hook) 2458 (gnus-run-hooks 'gnus-summary-update-hook)
2412 (forward-line 1)))) 2459 (forward-line 1))))
2413 2460
2414(defun gnus-summary-update-line (&optional dont-update) 2461(defun gnus-summary-update-line (&optional dont-update)
@@ -2434,13 +2481,13 @@ This is all marks except unread, ticked, dormant, and expirable."
2434 (if (or (null gnus-summary-default-score) 2481 (if (or (null gnus-summary-default-score)
2435 (<= (abs (- score gnus-summary-default-score)) 2482 (<= (abs (- score gnus-summary-default-score))
2436 gnus-summary-zcore-fuzz)) 2483 gnus-summary-zcore-fuzz))
2437 ? 2484 ? ;space
2438 (if (< score gnus-summary-default-score) 2485 (if (< score gnus-summary-default-score)
2439 gnus-score-below-mark gnus-score-over-mark)) 2486 gnus-score-below-mark gnus-score-over-mark))
2440 'score)) 2487 'score))
2441 ;; Do visual highlighting. 2488 ;; Do visual highlighting.
2442 (when (gnus-visual-p 'summary-highlight 'highlight) 2489 (when (gnus-visual-p 'summary-highlight 'highlight)
2443 (run-hooks 'gnus-summary-update-hook))))) 2490 (gnus-run-hooks 'gnus-summary-update-hook)))))
2444 2491
2445(defvar gnus-tmp-new-adopts nil) 2492(defvar gnus-tmp-new-adopts nil)
2446 2493
@@ -2482,14 +2529,14 @@ the thread are to be displayed."
2482 (and (consp elem) ; Has to be a cons. 2529 (and (consp elem) ; Has to be a cons.
2483 (consp (cdr elem)) ; The cdr has to be a list. 2530 (consp (cdr elem)) ; The cdr has to be a list.
2484 (symbolp (car elem)) ; Has to be a symbol in there. 2531 (symbolp (car elem)) ; Has to be a symbol in there.
2485 (not (memq (car elem) 2532 (not (memq (car elem) '(quit-config))) ; Ignore quit-config.
2486 '(quit-config to-address to-list to-group)))
2487 (ignore-errors ; So we set it. 2533 (ignore-errors ; So we set it.
2488 (make-local-variable (car elem)) 2534 (make-local-variable (car elem))
2489 (set (car elem) (eval (nth 1 elem)))))))) 2535 (set (car elem) (eval (nth 1 elem))))))))
2490 2536
2491(defun gnus-summary-read-group (group &optional show-all no-article 2537(defun gnus-summary-read-group (group &optional show-all no-article
2492 kill-buffer no-display) 2538 kill-buffer no-display backward
2539 select-articles)
2493 "Start reading news in newsgroup GROUP. 2540 "Start reading news in newsgroup GROUP.
2494If SHOW-ALL is non-nil, already read articles are also listed. 2541If SHOW-ALL is non-nil, already read articles are also listed.
2495If NO-ARTICLE is non-nil, no article is selected initially. 2542If NO-ARTICLE is non-nil, no article is selected initially.
@@ -2498,18 +2545,27 @@ If NO-DISPLAY, don't generate a summary buffer."
2498 (while (and group 2545 (while (and group
2499 (null (setq result 2546 (null (setq result
2500 (let ((gnus-auto-select-next nil)) 2547 (let ((gnus-auto-select-next nil))
2501 (gnus-summary-read-group-1 2548 (or (gnus-summary-read-group-1
2502 group show-all no-article 2549 group show-all no-article
2503 kill-buffer no-display)))) 2550 kill-buffer no-display
2551 select-articles)
2552 (setq show-all nil
2553 select-articles nil)))))
2504 (eq gnus-auto-select-next 'quietly)) 2554 (eq gnus-auto-select-next 'quietly))
2505 (set-buffer gnus-group-buffer) 2555 (set-buffer gnus-group-buffer)
2556 ;; The entry function called above goes to the next
2557 ;; group automatically, so we go two groups back
2558 ;; if we are searching for the previous group.
2559 (when backward
2560 (gnus-group-prev-unread-group 2))
2506 (if (not (equal group (gnus-group-group-name))) 2561 (if (not (equal group (gnus-group-group-name)))
2507 (setq group (gnus-group-group-name)) 2562 (setq group (gnus-group-group-name))
2508 (setq group nil))) 2563 (setq group nil)))
2509 result)) 2564 result))
2510 2565
2511(defun gnus-summary-read-group-1 (group show-all no-article 2566(defun gnus-summary-read-group-1 (group show-all no-article
2512 kill-buffer no-display) 2567 kill-buffer no-display
2568 &optional select-articles)
2513 ;; Killed foreign groups can't be entered. 2569 ;; Killed foreign groups can't be entered.
2514 (when (and (not (gnus-group-native-p group)) 2570 (when (and (not (gnus-group-native-p group))
2515 (not (gnus-gethash group gnus-newsrc-hashtb))) 2571 (not (gnus-gethash group gnus-newsrc-hashtb)))
@@ -2517,7 +2573,8 @@ If NO-DISPLAY, don't generate a summary buffer."
2517 (gnus-message 5 "Retrieving newsgroup: %s..." group) 2573 (gnus-message 5 "Retrieving newsgroup: %s..." group)
2518 (let* ((new-group (gnus-summary-setup-buffer group)) 2574 (let* ((new-group (gnus-summary-setup-buffer group))
2519 (quit-config (gnus-group-quit-config group)) 2575 (quit-config (gnus-group-quit-config group))
2520 (did-select (and new-group (gnus-select-newsgroup group show-all)))) 2576 (did-select (and new-group (gnus-select-newsgroup
2577 group show-all select-articles))))
2521 (cond 2578 (cond
2522 ;; This summary buffer exists already, so we just select it. 2579 ;; This summary buffer exists already, so we just select it.
2523 ((not new-group) 2580 ((not new-group)
@@ -2536,6 +2593,9 @@ If NO-DISPLAY, don't generate a summary buffer."
2536 (kill-buffer (current-buffer)) 2593 (kill-buffer (current-buffer))
2537 (if (not quit-config) 2594 (if (not quit-config)
2538 (progn 2595 (progn
2596 ;; Update the info -- marks might need to be removed,
2597 ;; for instance.
2598 (gnus-summary-update-info)
2539 (set-buffer gnus-group-buffer) 2599 (set-buffer gnus-group-buffer)
2540 (gnus-group-jump-to-group group) 2600 (gnus-group-jump-to-group group)
2541 (gnus-group-next-unread-group 1)) 2601 (gnus-group-next-unread-group 1))
@@ -2567,7 +2627,7 @@ If NO-DISPLAY, don't generate a summary buffer."
2567 (gnus-copy-sequence 2627 (gnus-copy-sequence
2568 (gnus-active gnus-newsgroup-name))) 2628 (gnus-active gnus-newsgroup-name)))
2569 ;; You can change the summary buffer in some way with this hook. 2629 ;; You can change the summary buffer in some way with this hook.
2570 (run-hooks 'gnus-select-group-hook) 2630 (gnus-run-hooks 'gnus-select-group-hook)
2571 ;; Set any local variables in the group parameters. 2631 ;; Set any local variables in the group parameters.
2572 (gnus-summary-set-local-parameters gnus-newsgroup-name) 2632 (gnus-summary-set-local-parameters gnus-newsgroup-name)
2573 (gnus-update-format-specifications 2633 (gnus-update-format-specifications
@@ -2605,7 +2665,7 @@ If NO-DISPLAY, don't generate a summary buffer."
2605 ((and gnus-newsgroup-scored show-all) 2665 ((and gnus-newsgroup-scored show-all)
2606 (gnus-summary-limit-include-expunged t)))) 2666 (gnus-summary-limit-include-expunged t))))
2607 ;; Function `gnus-apply-kill-file' must be called in this hook. 2667 ;; Function `gnus-apply-kill-file' must be called in this hook.
2608 (run-hooks 'gnus-apply-kill-hook) 2668 (gnus-run-hooks 'gnus-apply-kill-hook)
2609 (if (and (zerop (buffer-size)) 2669 (if (and (zerop (buffer-size))
2610 (not no-display)) 2670 (not no-display))
2611 (progn 2671 (progn
@@ -2622,6 +2682,8 @@ If NO-DISPLAY, don't generate a summary buffer."
2622 (and gnus-show-threads 2682 (and gnus-show-threads
2623 gnus-thread-hide-subtree 2683 gnus-thread-hide-subtree
2624 (gnus-summary-hide-all-threads)) 2684 (gnus-summary-hide-all-threads))
2685 (when kill-buffer
2686 (gnus-kill-or-deaden-summary kill-buffer))
2625 ;; Show first unread article if requested. 2687 ;; Show first unread article if requested.
2626 (if (and (not no-article) 2688 (if (and (not no-article)
2627 (not no-display) 2689 (not no-display)
@@ -2635,10 +2697,8 @@ If NO-DISPLAY, don't generate a summary buffer."
2635 ;; article in the group. 2697 ;; article in the group.
2636 (goto-char (point-min)) 2698 (goto-char (point-min))
2637 (gnus-summary-position-point) 2699 (gnus-summary-position-point)
2638 (gnus-set-mode-line 'summary) 2700 (gnus-configure-windows 'summary 'force)
2639 (gnus-configure-windows 'summary 'force)) 2701 (gnus-set-mode-line 'summary))
2640 (when kill-buffer
2641 (gnus-kill-or-deaden-summary kill-buffer))
2642 (when (get-buffer-window gnus-group-buffer t) 2702 (when (get-buffer-window gnus-group-buffer t)
2643 ;; Gotta use windows, because recenter does weird stuff if 2703 ;; Gotta use windows, because recenter does weird stuff if
2644 ;; the current buffer ain't the displayed window. 2704 ;; the current buffer ain't the displayed window.
@@ -2649,6 +2709,7 @@ If NO-DISPLAY, don't generate a summary buffer."
2649 (select-window owin))) 2709 (select-window owin)))
2650 ;; Mark this buffer as "prepared". 2710 ;; Mark this buffer as "prepared".
2651 (setq gnus-newsgroup-prepared t) 2711 (setq gnus-newsgroup-prepared t)
2712 (gnus-run-hooks 'gnus-summary-prepared-hook)
2652 t))))) 2713 t)))))
2653 2714
2654(defun gnus-summary-prepare () 2715(defun gnus-summary-prepare ()
@@ -2658,7 +2719,7 @@ If NO-DISPLAY, don't generate a summary buffer."
2658 (erase-buffer) 2719 (erase-buffer)
2659 (setq gnus-newsgroup-data nil 2720 (setq gnus-newsgroup-data nil
2660 gnus-newsgroup-data-reverse nil) 2721 gnus-newsgroup-data-reverse nil)
2661 (run-hooks 'gnus-summary-generate-hook) 2722 (gnus-run-hooks 'gnus-summary-generate-hook)
2662 ;; Generate the buffer, either with threads or without. 2723 ;; Generate the buffer, either with threads or without.
2663 (when gnus-newsgroup-headers 2724 (when gnus-newsgroup-headers
2664 (gnus-summary-prepare-threads 2725 (gnus-summary-prepare-threads
@@ -2672,13 +2733,15 @@ If NO-DISPLAY, don't generate a summary buffer."
2672 (setq gnus-newsgroup-data (nreverse gnus-newsgroup-data)) 2733 (setq gnus-newsgroup-data (nreverse gnus-newsgroup-data))
2673 ;; Call hooks for modifying summary buffer. 2734 ;; Call hooks for modifying summary buffer.
2674 (goto-char (point-min)) 2735 (goto-char (point-min))
2675 (run-hooks 'gnus-summary-prepare-hook))) 2736 (gnus-run-hooks 'gnus-summary-prepare-hook)))
2676 2737
2677(defsubst gnus-general-simplify-subject (subject) 2738(defsubst gnus-general-simplify-subject (subject)
2678 "Simply subject by the same rules as gnus-gather-threads-by-subject." 2739 "Simply subject by the same rules as gnus-gather-threads-by-subject."
2679 (setq subject 2740 (setq subject
2680 (cond 2741 (cond
2681 ;; Truncate the subject. 2742 ;; Truncate the subject.
2743 (gnus-simplify-subject-functions
2744 (gnus-map-function gnus-simplify-subject-functions subject))
2682 ((numberp gnus-summary-gather-subject-limit) 2745 ((numberp gnus-summary-gather-subject-limit)
2683 (setq subject (gnus-simplify-subject-re subject)) 2746 (setq subject (gnus-simplify-subject-re subject))
2684 (if (> (length subject) gnus-summary-gather-subject-limit) 2747 (if (> (length subject) gnus-summary-gather-subject-limit)
@@ -2699,7 +2762,6 @@ If NO-DISPLAY, don't generate a summary buffer."
2699(defun gnus-summary-simplify-subject-query () 2762(defun gnus-summary-simplify-subject-query ()
2700 "Query where the respool algorithm would put this article." 2763 "Query where the respool algorithm would put this article."
2701 (interactive) 2764 (interactive)
2702 (gnus-set-global-variables)
2703 (gnus-summary-select-article) 2765 (gnus-summary-select-article)
2704 (message (gnus-general-simplify-subject (gnus-summary-article-subject)))) 2766 (message (gnus-general-simplify-subject (gnus-summary-article-subject))))
2705 2767
@@ -2835,11 +2897,89 @@ If NO-DISPLAY, don't generate a summary buffer."
2835 gnus-newsgroup-dependencies))) 2897 gnus-newsgroup-dependencies)))
2836 threads)) 2898 threads))
2837 2899
2900;; Build the thread tree.
2901(defun gnus-dependencies-add-header (header dependencies force-new)
2902 "Enter HEADER into the DEPENDENCIES table if it is not already there.
2903
2904If FORCE-NEW is not nil, enter HEADER into the DEPENDENCIES table even
2905if it was already present.
2906
2907If `gnus-summary-ignore-duplicates' is nil then duplicate Message-IDs
2908will not be entered in the DEPENDENCIES table. Otherwise duplicate
2909Message-IDs will be renamed be renamed to a unique Message-ID before
2910being entered.
2911
2912Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise."
2913 (let* ((id (mail-header-id header))
2914 (id-dep (and id (intern id dependencies)))
2915 ref ref-dep ref-header)
2916 ;; Enter this `header' in the `dependencies' table.
2917 (cond
2918 ((not id-dep)
2919 (setq header nil))
2920 ;; The first two cases do the normal part: enter a new `header'
2921 ;; in the `dependencies' table.
2922 ((not (boundp id-dep))
2923 (set id-dep (list header)))
2924 ((null (car (symbol-value id-dep)))
2925 (setcar (symbol-value id-dep) header))
2926
2927 ;; From here the `header' was already present in the
2928 ;; `dependencies' table.
2929 (force-new
2930 ;; Overrides an existing entry;
2931 ;; just set the header part of the entry.
2932 (setcar (symbol-value id-dep) header))
2933
2934 ;; Renames the existing `header' to a unique Message-ID.
2935 ((not gnus-summary-ignore-duplicates)
2936 ;; An article with this Message-ID has already been seen.
2937 ;; We rename the Message-ID.
2938 (set (setq id-dep (intern (setq id (nnmail-message-id)) dependencies))
2939 (list header))
2940 (mail-header-set-id header id))
2941
2942 ;; The last case ignores an existing entry, except it adds any
2943 ;; additional Xrefs (in case the two articles came from different
2944 ;; servers.
2945 ;; Also sets `header' to `nil' meaning that the `dependencies'
2946 ;; table was *not* modified.
2947 (t
2948 (mail-header-set-xref
2949 (car (symbol-value id-dep))
2950 (concat (or (mail-header-xref (car (symbol-value id-dep)))
2951 "")
2952 (or (mail-header-xref header) "")))
2953 (setq header nil)))
2954
2955 (when header
2956 ;; First check if that we are not creating a References loop.
2957 (setq ref (gnus-parent-id (mail-header-references header)))
2958 (while (and ref
2959 (setq ref-dep (intern-soft ref dependencies))
2960 (boundp ref-dep)
2961 (setq ref-header (car (symbol-value ref-dep))))
2962 (if (string= id ref)
2963 ;; Yuk! This is a reference loop. Make the article be a
2964 ;; root article.
2965 (progn
2966 (mail-header-set-references (car (symbol-value id-dep)) "none")
2967 (setq ref nil))
2968 (setq ref (gnus-parent-id (mail-header-references ref-header)))))
2969 (setq ref (gnus-parent-id (mail-header-references header)))
2970 (setq ref-dep (intern (or ref "none") dependencies))
2971 (if (boundp ref-dep)
2972 (setcdr (symbol-value ref-dep)
2973 (nconc (cdr (symbol-value ref-dep))
2974 (list (symbol-value id-dep))))
2975 (set ref-dep (list nil (symbol-value id-dep)))))
2976 header))
2977
2838(defun gnus-build-sparse-threads () 2978(defun gnus-build-sparse-threads ()
2839 (let ((headers gnus-newsgroup-headers) 2979 (let ((headers gnus-newsgroup-headers)
2840 (deps gnus-newsgroup-dependencies) 2980 (gnus-summary-ignore-duplicates t)
2841 header references generation relations 2981 header references generation relations
2842 cthread subject child end pthread relation) 2982 subject child end new-child date)
2843 ;; First we create an alist of generations/relations, where 2983 ;; First we create an alist of generations/relations, where
2844 ;; generations is how much we trust the relation, and the relation 2984 ;; generations is how much we trust the relation, and the relation
2845 ;; is parent/child. 2985 ;; is parent/child.
@@ -2851,45 +2991,37 @@ If NO-DISPLAY, don't generate a summary buffer."
2851 (not (string= references ""))) 2991 (not (string= references "")))
2852 (insert references) 2992 (insert references)
2853 (setq child (mail-header-id header) 2993 (setq child (mail-header-id header)
2854 subject (mail-header-subject header)) 2994 subject (mail-header-subject header)
2855 (setq generation 0) 2995 date (mail-header-date header)
2996 generation 0)
2856 (while (search-backward ">" nil t) 2997 (while (search-backward ">" nil t)
2857 (setq end (1+ (point))) 2998 (setq end (1+ (point)))
2858 (when (search-backward "<" nil t) 2999 (when (search-backward "<" nil t)
3000 (setq new-child (buffer-substring (point) end))
2859 (push (list (incf generation) 3001 (push (list (incf generation)
2860 child (setq child (buffer-substring (point) end)) 3002 child (setq child new-child)
2861 subject) 3003 subject date)
2862 relations))) 3004 relations)))
2863 (push (list (1+ generation) child nil subject) relations) 3005 (when child
3006 (push (list (1+ generation) child nil subject) relations))
2864 (erase-buffer))) 3007 (erase-buffer)))
2865 (kill-buffer (current-buffer))) 3008 (kill-buffer (current-buffer)))
2866 ;; Sort over trustworthiness. 3009 ;; Sort over trustworthiness.
2867 (setq relations (sort relations (lambda (r1 r2) (< (car r1) (car r2))))) 3010 (mapcar
2868 (while (setq relation (pop relations)) 3011 (lambda (relation)
2869 (when (if (boundp (setq cthread (intern (cadr relation) deps))) 3012 (when (gnus-dependencies-add-header
2870 (unless (car (symbol-value cthread)) 3013 (make-full-mail-header
2871 ;; Make this article the parent of these threads. 3014 gnus-reffed-article-number
2872 (setcar (symbol-value cthread) 3015 (nth 3 relation) "" (or (nth 4 relation) "")
2873 (vector gnus-reffed-article-number 3016 (nth 1 relation)
2874 (cadddr relation) 3017 (or (nth 2 relation) "") 0 0 "")
2875 "" "" 3018 gnus-newsgroup-dependencies nil)
2876 (cadr relation) 3019 (push gnus-reffed-article-number gnus-newsgroup-limit)
2877 (or (caddr relation) "") 0 0 ""))) 3020 (push gnus-reffed-article-number gnus-newsgroup-sparse)
2878 (set cthread (list (vector gnus-reffed-article-number 3021 (push (cons gnus-reffed-article-number gnus-sparse-mark)
2879 (cadddr relation) 3022 gnus-newsgroup-reads)
2880 "" "" (cadr relation) 3023 (decf gnus-reffed-article-number)))
2881 (or (caddr relation) "") 0 0 "")))) 3024 (sort relations 'car-less-than-car))
2882 (push gnus-reffed-article-number gnus-newsgroup-limit)
2883 (push gnus-reffed-article-number gnus-newsgroup-sparse)
2884 (push (cons gnus-reffed-article-number gnus-sparse-mark)
2885 gnus-newsgroup-reads)
2886 (decf gnus-reffed-article-number)
2887 ;; Make this new thread the child of its parent.
2888 (if (boundp (setq pthread (intern (or (caddr relation) "none") deps)))
2889 (setcdr (symbol-value pthread)
2890 (nconc (cdr (symbol-value pthread))
2891 (list (symbol-value cthread))))
2892 (set pthread (list nil (symbol-value cthread))))))
2893 (gnus-message 7 "Making sparse threads...done"))) 3025 (gnus-message 7 "Making sparse threads...done")))
2894 3026
2895(defun gnus-build-old-threads () 3027(defun gnus-build-old-threads ()
@@ -2908,11 +3040,64 @@ If NO-DISPLAY, don't generate a summary buffer."
2908 (setq heads (cdr heads)) 3040 (setq heads (cdr heads))
2909 (setq id (symbol-name refs)) 3041 (setq id (symbol-name refs))
2910 (while (and (setq id (gnus-build-get-header id)) 3042 (while (and (setq id (gnus-build-get-header id))
2911 (not (car (gnus-gethash 3043 (not (car (gnus-id-to-thread id)))))
2912 id gnus-newsgroup-dependencies)))))
2913 (setq heads nil))))) 3044 (setq heads nil)))))
2914 gnus-newsgroup-dependencies))) 3045 gnus-newsgroup-dependencies)))
2915 3046
3047;; The following macros and functions were written by Felix Lee
3048;; <flee@cse.psu.edu>.
3049
3050(defmacro gnus-nov-read-integer ()
3051 '(prog1
3052 (if (= (following-char) ?\t)
3053 0
3054 (let ((num (ignore-errors (read buffer))))
3055 (if (numberp num) num 0)))
3056 (unless (eobp)
3057 (search-forward "\t" eol 'move))))
3058
3059(defmacro gnus-nov-skip-field ()
3060 '(search-forward "\t" eol 'move))
3061
3062(defmacro gnus-nov-field ()
3063 '(buffer-substring (point) (if (gnus-nov-skip-field) (1- (point)) eol)))
3064
3065;; This function has to be called with point after the article number
3066;; on the beginning of the line.
3067(defsubst gnus-nov-parse-line (number dependencies &optional force-new)
3068 (let ((eol (gnus-point-at-eol))
3069 (buffer (current-buffer))
3070 header)
3071
3072 ;; overview: [num subject from date id refs chars lines misc]
3073 (unwind-protect
3074 (progn
3075 (narrow-to-region (point) eol)
3076 (unless (eobp)
3077 (forward-char))
3078
3079 (setq header
3080 (make-full-mail-header
3081 number ; number
3082 (funcall
3083 gnus-unstructured-field-decoder (gnus-nov-field)) ; subject
3084 (funcall
3085 gnus-structured-field-decoder (gnus-nov-field)) ; from
3086 (gnus-nov-field) ; date
3087 (or (gnus-nov-field)
3088 (nnheader-generate-fake-message-id)) ; id
3089 (gnus-nov-field) ; refs
3090 (gnus-nov-read-integer) ; chars
3091 (gnus-nov-read-integer) ; lines
3092 (unless (= (following-char) ?\n)
3093 (gnus-nov-field))))) ; misc
3094
3095 (widen))
3096
3097 (when gnus-alter-header-function
3098 (funcall gnus-alter-header-function header))
3099 (gnus-dependencies-add-header header dependencies force-new)))
3100
2916(defun gnus-build-get-header (id) 3101(defun gnus-build-get-header (id)
2917 ;; Look through the buffer of NOV lines and find the header to 3102 ;; Look through the buffer of NOV lines and find the header to
2918 ;; ID. Enter this line into the dependencies hash table, and return 3103 ;; ID. Enter this line into the dependencies hash table, and return
@@ -2948,6 +3133,33 @@ If NO-DISPLAY, don't generate a summary buffer."
2948 (delq number gnus-newsgroup-unselected))) 3133 (delq number gnus-newsgroup-unselected)))
2949 (push number gnus-newsgroup-ancient))))))) 3134 (push number gnus-newsgroup-ancient)))))))
2950 3135
3136(defun gnus-build-all-threads ()
3137 "Read all the headers."
3138 (let ((gnus-summary-ignore-duplicates t)
3139 (dependencies gnus-newsgroup-dependencies)
3140 header article)
3141 (save-excursion
3142 (set-buffer nntp-server-buffer)
3143 (let ((case-fold-search nil))
3144 (goto-char (point-min))
3145 (while (not (eobp))
3146 (ignore-errors
3147 (setq article (read (current-buffer))
3148 header (gnus-nov-parse-line
3149 article dependencies)))
3150 (when header
3151 (save-excursion
3152 (set-buffer gnus-summary-buffer)
3153 (push header gnus-newsgroup-headers)
3154 (if (memq (setq article (mail-header-number header))
3155 gnus-newsgroup-unselected)
3156 (progn
3157 (push article gnus-newsgroup-unreads)
3158 (setq gnus-newsgroup-unselected
3159 (delq article gnus-newsgroup-unselected)))
3160 (push article gnus-newsgroup-ancient)))
3161 (forward-line 1)))))))
3162
2951(defun gnus-summary-update-article-line (article header) 3163(defun gnus-summary-update-article-line (article header)
2952 "Update the line for ARTICLE using HEADERS." 3164 "Update the line for ARTICLE using HEADERS."
2953 (let* ((id (mail-header-id header)) 3165 (let* ((id (mail-header-id header))
@@ -2993,7 +3205,7 @@ If NO-DISPLAY, don't generate a summary buffer."
2993(defun gnus-summary-update-article (article &optional iheader) 3205(defun gnus-summary-update-article (article &optional iheader)
2994 "Update ARTICLE in the summary buffer." 3206 "Update ARTICLE in the summary buffer."
2995 (set-buffer gnus-summary-buffer) 3207 (set-buffer gnus-summary-buffer)
2996 (let* ((header (or iheader (gnus-summary-article-header article))) 3208 (let* ((header (gnus-summary-article-header article))
2997 (id (mail-header-id header)) 3209 (id (mail-header-id header))
2998 (data (gnus-data-find article)) 3210 (data (gnus-data-find article))
2999 (thread (gnus-id-to-thread id)) 3211 (thread (gnus-id-to-thread id))
@@ -3006,23 +3218,21 @@ If NO-DISPLAY, don't generate a summary buffer."
3006 references)) 3218 references))
3007 "none"))) 3219 "none")))
3008 (buffer-read-only nil) 3220 (buffer-read-only nil)
3009 (old (car thread)) 3221 (old (car thread)))
3010 (number (mail-header-number header))
3011 pos)
3012 (when thread 3222 (when thread
3013 ;; !!! Should this be in or not?
3014 (unless iheader 3223 (unless iheader
3015 (setcar thread nil)) 3224 (setcar thread nil)
3016 (when parent 3225 (when parent
3017 (delq thread parent)) 3226 (delq thread parent)))
3018 (if (gnus-summary-insert-subject id header iheader) 3227 (if (gnus-summary-insert-subject id header)
3019 ;; Set the (possibly) new article number in the data structure. 3228 ;; Set the (possibly) new article number in the data structure.
3020 (gnus-data-set-number data (gnus-id-to-article id)) 3229 (gnus-data-set-number data (gnus-id-to-article id))
3021 (setcar thread old) 3230 (setcar thread old)
3022 nil)))) 3231 nil))))
3023 3232
3024(defun gnus-rebuild-thread (id) 3233(defun gnus-rebuild-thread (id &optional line)
3025 "Rebuild the thread containing ID." 3234 "Rebuild the thread containing ID.
3235If LINE, insert the rebuilt thread starting on line LINE."
3026 (let ((buffer-read-only nil) 3236 (let ((buffer-read-only nil)
3027 old-pos current thread data) 3237 old-pos current thread data)
3028 (if (not gnus-show-threads) 3238 (if (not gnus-show-threads)
@@ -3052,6 +3262,9 @@ If NO-DISPLAY, don't generate a summary buffer."
3052 (setq thread (cons subject (gnus-sort-threads roots)))))) 3262 (setq thread (cons subject (gnus-sort-threads roots))))))
3053 (let (threads) 3263 (let (threads)
3054 ;; We then insert this thread into the summary buffer. 3264 ;; We then insert this thread into the summary buffer.
3265 (when line
3266 (goto-char (point-min))
3267 (forward-line (1- line)))
3055 (let (gnus-newsgroup-data gnus-newsgroup-threads) 3268 (let (gnus-newsgroup-data gnus-newsgroup-threads)
3056 (if gnus-show-threads 3269 (if gnus-show-threads
3057 (gnus-summary-prepare-threads (gnus-cut-threads (list thread))) 3270 (gnus-summary-prepare-threads (gnus-cut-threads (list thread)))
@@ -3059,8 +3272,15 @@ If NO-DISPLAY, don't generate a summary buffer."
3059 (setq data (nreverse gnus-newsgroup-data)) 3272 (setq data (nreverse gnus-newsgroup-data))
3060 (setq threads gnus-newsgroup-threads)) 3273 (setq threads gnus-newsgroup-threads))
3061 ;; We splice the new data into the data structure. 3274 ;; We splice the new data into the data structure.
3062 (gnus-data-enter-list current data (- (point) old-pos)) 3275 ;;!!! This is kinda bogus. We assume that in LINE is non-nil,
3063 (setq gnus-newsgroup-threads (nconc threads gnus-newsgroup-threads))))) 3276 ;;!!! then we want to insert at the beginning of the buffer.
3277 ;;!!! That happens to be true with Gnus now, but that may
3278 ;;!!! change in the future. Perhaps.
3279 (gnus-data-enter-list
3280 (if line nil current) data (- (point) old-pos))
3281 (setq gnus-newsgroup-threads
3282 (nconc threads gnus-newsgroup-threads))
3283 (gnus-data-compute-positions))))
3064 3284
3065(defun gnus-number-to-header (number) 3285(defun gnus-number-to-header (number)
3066 "Return the header for article NUMBER." 3286 "Return the header for article NUMBER."
@@ -3071,19 +3291,23 @@ If NO-DISPLAY, don't generate a summary buffer."
3071 (when headers 3291 (when headers
3072 (car headers)))) 3292 (car headers))))
3073 3293
3074(defun gnus-parent-headers (headers &optional generation) 3294(defun gnus-parent-headers (in-headers &optional generation)
3075 "Return the headers of the GENERATIONeth parent of HEADERS." 3295 "Return the headers of the GENERATIONeth parent of HEADERS."
3076 (unless generation 3296 (unless generation
3077 (setq generation 1)) 3297 (setq generation 1))
3078 (let ((parent t) 3298 (let ((parent t)
3299 (headers in-headers)
3079 references) 3300 references)
3080 (while (and parent headers (not (zerop generation))) 3301 (while (and parent
3081 (setq references (mail-header-references headers)) 3302 (not (zerop generation))
3082 (when (and references 3303 (setq references (mail-header-references headers)))
3083 (setq parent (gnus-parent-id references)) 3304 (setq headers (if (and references
3084 (setq headers (car (gnus-id-to-thread parent)))) 3305 (setq parent (gnus-parent-id references)))
3085 (decf generation))) 3306 (car (gnus-id-to-thread parent))
3086 headers)) 3307 nil))
3308 (decf generation))
3309 (and (not (eq headers in-headers))
3310 headers)))
3087 3311
3088(defun gnus-id-to-thread (id) 3312(defun gnus-id-to-thread (id)
3089 "Return the (sub-)thread where ID appears." 3313 "Return the (sub-)thread where ID appears."
@@ -3118,20 +3342,22 @@ If NO-DISPLAY, don't generate a summary buffer."
3118(defun gnus-root-id (id) 3342(defun gnus-root-id (id)
3119 "Return the id of the root of the thread where ID appears." 3343 "Return the id of the root of the thread where ID appears."
3120 (let (last-id prev) 3344 (let (last-id prev)
3121 (while (and id (setq prev (car (gnus-gethash 3345 (while (and id (setq prev (car (gnus-id-to-thread id))))
3122 id gnus-newsgroup-dependencies))))
3123 (setq last-id id 3346 (setq last-id id
3124 id (gnus-parent-id (mail-header-references prev)))) 3347 id (gnus-parent-id (mail-header-references prev))))
3125 last-id)) 3348 last-id))
3126 3349
3350(defun gnus-articles-in-thread (thread)
3351 "Return the list of articles in THREAD."
3352 (cons (mail-header-number (car thread))
3353 (apply 'nconc (mapcar 'gnus-articles-in-thread (cdr thread)))))
3354
3127(defun gnus-remove-thread (id &optional dont-remove) 3355(defun gnus-remove-thread (id &optional dont-remove)
3128 "Remove the thread that has ID in it." 3356 "Remove the thread that has ID in it."
3129 (let ((dep gnus-newsgroup-dependencies) 3357 (let (headers thread last-id)
3130 headers thread last-id)
3131 ;; First go up in this thread until we find the root. 3358 ;; First go up in this thread until we find the root.
3132 (setq last-id (gnus-root-id id)) 3359 (setq last-id (gnus-root-id id)
3133 (setq headers (list (car (gnus-id-to-thread last-id)) 3360 headers (message-flatten-list (gnus-id-to-thread last-id)))
3134 (caadr (gnus-id-to-thread last-id))))
3135 ;; We have now found the real root of this thread. It might have 3361 ;; We have now found the real root of this thread. It might have
3136 ;; been gathered into some loose thread, so we have to search 3362 ;; been gathered into some loose thread, so we have to search
3137 ;; through the threads to find the thread we wanted. 3363 ;; through the threads to find the thread we wanted.
@@ -3160,7 +3386,7 @@ If NO-DISPLAY, don't generate a summary buffer."
3160 (if thread 3386 (if thread
3161 (unless dont-remove 3387 (unless dont-remove
3162 (setq gnus-newsgroup-threads (delq thread gnus-newsgroup-threads))) 3388 (setq gnus-newsgroup-threads (delq thread gnus-newsgroup-threads)))
3163 (setq thread (gnus-gethash last-id dep))) 3389 (setq thread (gnus-id-to-thread last-id)))
3164 (when thread 3390 (when thread
3165 (prog1 3391 (prog1
3166 thread ; We return this thread. 3392 thread ; We return this thread.
@@ -3170,12 +3396,18 @@ If NO-DISPLAY, don't generate a summary buffer."
3170 ;; If we use dummy roots, then we have to remove the 3396 ;; If we use dummy roots, then we have to remove the
3171 ;; dummy root as well. 3397 ;; dummy root as well.
3172 (when (eq gnus-summary-make-false-root 'dummy) 3398 (when (eq gnus-summary-make-false-root 'dummy)
3399 ;; We go to the dummy root by going to
3400 ;; the first sub-"thread", and then one line up.
3401 (gnus-summary-goto-article
3402 (mail-header-number (caadr thread)))
3403 (forward-line -1)
3173 (gnus-delete-line) 3404 (gnus-delete-line)
3174 (gnus-data-compute-positions)) 3405 (gnus-data-compute-positions))
3175 (setq thread (cdr thread)) 3406 (setq thread (cdr thread))
3176 (while thread 3407 (while thread
3177 (gnus-remove-thread-1 (car thread)) 3408 (gnus-remove-thread-1 (car thread))
3178 (setq thread (cdr thread)))) 3409 (setq thread (cdr thread))))
3410 (gnus-summary-show-all-threads)
3179 (gnus-remove-thread-1 thread)))))))) 3411 (gnus-remove-thread-1 thread))))))))
3180 3412
3181(defun gnus-remove-thread-1 (thread) 3413(defun gnus-remove-thread-1 (thread)
@@ -3198,10 +3430,10 @@ If NO-DISPLAY, don't generate a summary buffer."
3198 "Sort THREADS." 3430 "Sort THREADS."
3199 (if (not gnus-thread-sort-functions) 3431 (if (not gnus-thread-sort-functions)
3200 threads 3432 threads
3201 (gnus-message 7 "Sorting threads...") 3433 (gnus-message 8 "Sorting threads...")
3202 (prog1 3434 (prog1
3203 (sort threads (gnus-make-sort-function gnus-thread-sort-functions)) 3435 (sort threads (gnus-make-sort-function gnus-thread-sort-functions))
3204 (gnus-message 7 "Sorting threads...done")))) 3436 (gnus-message 8 "Sorting threads...done"))))
3205 3437
3206(defun gnus-sort-articles (articles) 3438(defun gnus-sort-articles (articles)
3207 "Sort ARTICLES." 3439 "Sort ARTICLES."
@@ -3320,8 +3552,7 @@ Unscored articles will be counted as having a score of zero."
3320 (apply gnus-thread-score-function 3552 (apply gnus-thread-score-function
3321 (or (append 3553 (or (append
3322 (mapcar 'gnus-thread-total-score 3554 (mapcar 'gnus-thread-total-score
3323 (cdr (gnus-gethash (mail-header-id root) 3555 (cdr (gnus-id-to-thread (mail-header-id root))))
3324 gnus-newsgroup-dependencies)))
3325 (when (> (mail-header-number root) 0) 3556 (when (> (mail-header-number root) 0)
3326 (list (or (cdr (assq (mail-header-number root) 3557 (list (or (cdr (assq (mail-header-number root)
3327 gnus-newsgroup-scored)) 3558 gnus-newsgroup-scored))
@@ -3368,7 +3599,6 @@ or a straight list of headers."
3368 (while (or threads stack gnus-tmp-new-adopts new-roots) 3599 (while (or threads stack gnus-tmp-new-adopts new-roots)
3369 3600
3370 (if (and (= gnus-tmp-level 0) 3601 (if (and (= gnus-tmp-level 0)
3371 (not (setq gnus-tmp-dummy-line nil))
3372 (or (not stack) 3602 (or (not stack)
3373 (= (caar stack) 0)) 3603 (= (caar stack) 0))
3374 (not gnus-tmp-false-parent) 3604 (not gnus-tmp-false-parent)
@@ -3483,7 +3713,10 @@ or a straight list of headers."
3483 (when gnus-tmp-header 3713 (when gnus-tmp-header
3484 ;; We may have an old dummy line to output before this 3714 ;; We may have an old dummy line to output before this
3485 ;; article. 3715 ;; article.
3486 (when gnus-tmp-dummy-line 3716 (when (and gnus-tmp-dummy-line
3717 (gnus-subject-equal
3718 gnus-tmp-dummy-line
3719 (mail-header-subject gnus-tmp-header)))
3487 (gnus-summary-insert-dummy-line 3720 (gnus-summary-insert-dummy-line
3488 gnus-tmp-dummy-line (mail-header-number gnus-tmp-header)) 3721 gnus-tmp-dummy-line (mail-header-number gnus-tmp-header))
3489 (setq gnus-tmp-dummy-line nil)) 3722 (setq gnus-tmp-dummy-line nil))
@@ -3530,7 +3763,7 @@ or a straight list of headers."
3530 (if (or (null gnus-summary-default-score) 3763 (if (or (null gnus-summary-default-score)
3531 (<= (abs (- gnus-tmp-score gnus-summary-default-score)) 3764 (<= (abs (- gnus-tmp-score gnus-summary-default-score))
3532 gnus-summary-zcore-fuzz)) 3765 gnus-summary-zcore-fuzz))
3533 ? 3766 ? ;space
3534 (if (< gnus-tmp-score gnus-summary-default-score) 3767 (if (< gnus-tmp-score gnus-summary-default-score)
3535 gnus-score-below-mark gnus-score-over-mark)) 3768 gnus-score-below-mark gnus-score-over-mark))
3536 gnus-tmp-replied 3769 gnus-tmp-replied
@@ -3560,13 +3793,13 @@ or a straight list of headers."
3560 (setq gnus-tmp-name gnus-tmp-from)) 3793 (setq gnus-tmp-name gnus-tmp-from))
3561 (unless (numberp gnus-tmp-lines) 3794 (unless (numberp gnus-tmp-lines)
3562 (setq gnus-tmp-lines 0)) 3795 (setq gnus-tmp-lines 0))
3563 (gnus-put-text-property 3796 (gnus-put-text-property-excluding-characters-with-faces
3564 (point) 3797 (point)
3565 (progn (eval gnus-summary-line-format-spec) (point)) 3798 (progn (eval gnus-summary-line-format-spec) (point))
3566 'gnus-number number) 3799 'gnus-number number)
3567 (when gnus-visual-p 3800 (when gnus-visual-p
3568 (forward-line -1) 3801 (forward-line -1)
3569 (run-hooks 'gnus-summary-update-hook) 3802 (gnus-run-hooks 'gnus-summary-update-hook)
3570 (forward-line 1)) 3803 (forward-line 1))
3571 3804
3572 (setq gnus-tmp-prev-subject subject))) 3805 (setq gnus-tmp-prev-subject subject)))
@@ -3614,13 +3847,14 @@ or a straight list of headers."
3614 (cdr (assq number gnus-newsgroup-scored)) 3847 (cdr (assq number gnus-newsgroup-scored))
3615 (memq number gnus-newsgroup-processable)))))) 3848 (memq number gnus-newsgroup-processable))))))
3616 3849
3617(defun gnus-select-newsgroup (group &optional read-all) 3850(defun gnus-select-newsgroup (group &optional read-all select-articles)
3618 "Select newsgroup GROUP. 3851 "Select newsgroup GROUP.
3619If READ-ALL is non-nil, all articles in the group are selected." 3852If READ-ALL is non-nil, all articles in the group are selected.
3853If SELECT-ARTICLES, only select those articles from GROUP."
3620 (let* ((entry (gnus-gethash group gnus-newsrc-hashtb)) 3854 (let* ((entry (gnus-gethash group gnus-newsrc-hashtb))
3621 ;;!!! Dirty hack; should be removed. 3855 ;;!!! Dirty hack; should be removed.
3622 (gnus-summary-ignore-duplicates 3856 (gnus-summary-ignore-duplicates
3623 (if (eq (car (gnus-find-method-for-group group)) 'nnvirtual) 3857 (if (eq (car (gnus-find-method-for-group group)) 'nnvirtual)
3624 t 3858 t
3625 gnus-summary-ignore-duplicates)) 3859 gnus-summary-ignore-duplicates))
3626 (info (nth 2 entry)) 3860 (info (nth 2 entry))
@@ -3665,10 +3899,13 @@ If READ-ALL is non-nil, all articles in the group are selected."
3665 (setq gnus-newsgroup-processable nil) 3899 (setq gnus-newsgroup-processable nil)
3666 3900
3667 (gnus-update-read-articles group gnus-newsgroup-unreads) 3901 (gnus-update-read-articles group gnus-newsgroup-unreads)
3668 (unless (gnus-ephemeral-group-p gnus-newsgroup-name)
3669 (gnus-group-update-group group))
3670 3902
3671 (setq articles (gnus-articles-to-read group read-all)) 3903 (if (setq articles select-articles)
3904 (setq gnus-newsgroup-unselected
3905 (gnus-sorted-intersection
3906 gnus-newsgroup-unreads
3907 (gnus-sorted-complement gnus-newsgroup-unreads articles)))
3908 (setq articles (gnus-articles-to-read group read-all)))
3672 3909
3673 (cond 3910 (cond
3674 ((null articles) 3911 ((null articles)
@@ -3688,11 +3925,11 @@ If READ-ALL is non-nil, all articles in the group are selected."
3688 articles gnus-newsgroup-name 3925 articles gnus-newsgroup-name
3689 ;; We might want to fetch old headers, but 3926 ;; We might want to fetch old headers, but
3690 ;; not if there is only 1 article. 3927 ;; not if there is only 1 article.
3691 (and gnus-fetch-old-headers 3928 (and (or (and
3692 (or (and
3693 (not (eq gnus-fetch-old-headers 'some)) 3929 (not (eq gnus-fetch-old-headers 'some))
3694 (not (numberp gnus-fetch-old-headers))) 3930 (not (numberp gnus-fetch-old-headers)))
3695 (> (length articles) 1)))))) 3931 (> (length articles) 1))
3932 gnus-fetch-old-headers))))
3696 (gnus-get-newsgroup-headers-xover 3933 (gnus-get-newsgroup-headers-xover
3697 articles nil nil gnus-newsgroup-name t) 3934 articles nil nil gnus-newsgroup-name t)
3698 (gnus-get-newsgroup-headers))) 3935 (gnus-get-newsgroup-headers)))
@@ -3719,9 +3956,14 @@ If READ-ALL is non-nil, all articles in the group are selected."
3719 (gnus-update-missing-marks 3956 (gnus-update-missing-marks
3720 (gnus-sorted-complement fetched-articles articles)) 3957 (gnus-sorted-complement fetched-articles articles))
3721 ;; We might want to build some more threads first. 3958 ;; We might want to build some more threads first.
3722 (and gnus-fetch-old-headers 3959 (when (and gnus-fetch-old-headers
3723 (eq gnus-headers-retrieved-by 'nov) 3960 (eq gnus-headers-retrieved-by 'nov))
3724 (gnus-build-old-threads)) 3961 (if (eq gnus-fetch-old-headers 'invisible)
3962 (gnus-build-all-threads)
3963 (gnus-build-old-threads)))
3964 ;; Let the Gnus agent mark articles as read.
3965 (when gnus-agent
3966 (gnus-agent-get-undownloaded-list))
3725 ;; Check whether auto-expire is to be done in this group. 3967 ;; Check whether auto-expire is to be done in this group.
3726 (setq gnus-newsgroup-auto-expire 3968 (setq gnus-newsgroup-auto-expire
3727 (gnus-group-auto-expirable-p group)) 3969 (gnus-group-auto-expirable-p group))
@@ -3865,7 +4107,7 @@ If READ-ALL is non-nil, all articles in the group are selected."
3865 (set var (delq article (symbol-value var)))))))))) 4107 (set var (delq article (symbol-value var))))))))))
3866 4108
3867(defun gnus-update-missing-marks (missing) 4109(defun gnus-update-missing-marks (missing)
3868 "Go through the list of MISSING articles and remove them mark lists." 4110 "Go through the list of MISSING articles and remove them from the mark lists."
3869 (when missing 4111 (when missing
3870 (let ((types gnus-article-mark-lists) 4112 (let ((types gnus-article-mark-lists)
3871 var m) 4113 var m)
@@ -4055,6 +4297,41 @@ The resulting hash table is returned, or nil if no Xrefs were found."
4055 (gnus-group-make-articles-read name idlist)))) 4297 (gnus-group-make-articles-read name idlist))))
4056 xref-hashtb))))) 4298 xref-hashtb)))))
4057 4299
4300(defun gnus-compute-read-articles (group articles)
4301 (let* ((entry (gnus-gethash group gnus-newsrc-hashtb))
4302 (info (nth 2 entry))
4303 (active (gnus-active group))
4304 ninfo)
4305 (when entry
4306 ;; First peel off all illegal article numbers.
4307 (when active
4308 (let ((ids articles)
4309 id first)
4310 (while (setq id (pop ids))
4311 (when (and first (> id (cdr active)))
4312 ;; We'll end up in this situation in one particular
4313 ;; obscure situation. If you re-scan a group and get
4314 ;; a new article that is cross-posted to a different
4315 ;; group that has not been re-scanned, you might get
4316 ;; crossposted article that has a higher number than
4317 ;; Gnus believes possible. So we re-activate this
4318 ;; group as well. This might mean doing the
4319 ;; crossposting thingy will *increase* the number
4320 ;; of articles in some groups. Tsk, tsk.
4321 (setq active (or (gnus-activate-group group) active)))
4322 (when (or (> id (cdr active))
4323 (< id (car active)))
4324 (setq articles (delq id articles))))))
4325 ;; If the read list is nil, we init it.
4326 (if (and active
4327 (null (gnus-info-read info))
4328 (> (car active) 1))
4329 (setq ninfo (cons 1 (1- (car active))))
4330 (setq ninfo (gnus-info-read info)))
4331 ;; Then we add the read articles to the range.
4332 (gnus-add-to-range
4333 ninfo (setq articles (sort articles '<))))))
4334
4058(defun gnus-group-make-articles-read (group articles) 4335(defun gnus-group-make-articles-read (group articles)
4059 "Update the info of GROUP to say that ARTICLES are read." 4336 "Update the info of GROUP to say that ARTICLES are read."
4060 (let* ((num 0) 4337 (let* ((num 0)
@@ -4062,64 +4339,38 @@ The resulting hash table is returned, or nil if no Xrefs were found."
4062 (info (nth 2 entry)) 4339 (info (nth 2 entry))
4063 (active (gnus-active group)) 4340 (active (gnus-active group))
4064 range) 4341 range)
4065 ;; First peel off all illegal article numbers. 4342 (when entry
4066 (when active 4343 (setq range (gnus-compute-read-articles group articles))
4067 (let ((ids articles) 4344 (save-excursion
4068 id first) 4345 (set-buffer gnus-group-buffer)
4069 (while (setq id (pop ids)) 4346 (gnus-undo-register
4070 (when (and first (> id (cdr active))) 4347 `(progn
4071 ;; We'll end up in this situation in one particular 4348 (gnus-info-set-marks ',info ',(gnus-info-marks info) t)
4072 ;; obscure situation. If you re-scan a group and get 4349 (gnus-info-set-read ',info ',(gnus-info-read info))
4073 ;; a new article that is cross-posted to a different 4350 (gnus-get-unread-articles-in-group ',info (gnus-active ,group))
4074 ;; group that has not been re-scanned, you might get 4351 (gnus-group-update-group ,group t))))
4075 ;; crossposted article that has a higher number than 4352 ;; Add the read articles to the range.
4076 ;; Gnus believes possible. So we re-activate this 4353 (gnus-info-set-read info range)
4077 ;; group as well. This might mean doing the 4354 ;; Then we have to re-compute how many unread
4078 ;; crossposting thingy will *increase* the number 4355 ;; articles there are in this group.
4079 ;; of articles in some groups. Tsk, tsk. 4356 (when active
4080 (setq active (or (gnus-activate-group group) active))) 4357 (cond
4081 (when (or (> id (cdr active)) 4358 ((not range)
4082 (< id (car active))) 4359 (setq num (- (1+ (cdr active)) (car active))))
4083 (setq articles (delq id articles)))))) 4360 ((not (listp (cdr range)))
4084 (save-excursion 4361 (setq num (- (cdr active) (- (1+ (cdr range))
4085 (set-buffer gnus-group-buffer) 4362 (car range)))))
4086 (gnus-undo-register 4363 (t
4087 `(progn 4364 (while range
4088 (gnus-info-set-marks ',info ',(gnus-info-marks info) t) 4365 (if (numberp (car range))
4089 (gnus-info-set-read ',info ',(gnus-info-read info)) 4366 (setq num (1+ num))
4090 (gnus-get-unread-articles-in-group ',info (gnus-active ,group)) 4367 (setq num (+ num (- (1+ (cdar range)) (caar range)))))
4091 (gnus-group-update-group ,group t)))) 4368 (setq range (cdr range)))
4092 ;; If the read list is nil, we init it. 4369 (setq num (- (cdr active) num))))
4093 (and active 4370 ;; Update the number of unread articles.
4094 (null (gnus-info-read info)) 4371 (setcar entry num)
4095 (> (car active) 1) 4372 ;; Update the group buffer.
4096 (gnus-info-set-read info (cons 1 (1- (car active))))) 4373 (gnus-group-update-group group t)))))
4097 ;; Then we add the read articles to the range.
4098 (gnus-info-set-read
4099 info
4100 (setq range
4101 (gnus-add-to-range
4102 (gnus-info-read info) (setq articles (sort articles '<)))))
4103 ;; Then we have to re-compute how many unread
4104 ;; articles there are in this group.
4105 (when active
4106 (cond
4107 ((not range)
4108 (setq num (- (1+ (cdr active)) (car active))))
4109 ((not (listp (cdr range)))
4110 (setq num (- (cdr active) (- (1+ (cdr range))
4111 (car range)))))
4112 (t
4113 (while range
4114 (if (numberp (car range))
4115 (setq num (1+ num))
4116 (setq num (+ num (- (1+ (cdar range)) (caar range)))))
4117 (setq range (cdr range)))
4118 (setq num (- (cdr active) num))))
4119 ;; Update the number of unread articles.
4120 (setcar entry num)
4121 ;; Update the group buffer.
4122 (gnus-group-update-group group t))))
4123 4374
4124(defun gnus-methods-equal-p (m1 m2) 4375(defun gnus-methods-equal-p (m1 m2)
4125 (let ((m1 (or m1 gnus-select-method)) 4376 (let ((m1 (or m1 gnus-select-method))
@@ -4138,14 +4389,14 @@ The resulting hash table is returned, or nil if no Xrefs were found."
4138 (or dependencies 4389 (or dependencies
4139 (save-excursion (set-buffer gnus-summary-buffer) 4390 (save-excursion (set-buffer gnus-summary-buffer)
4140 gnus-newsgroup-dependencies))) 4391 gnus-newsgroup-dependencies)))
4141 headers id id-dep ref-dep end ref) 4392 headers id end ref)
4142 (save-excursion 4393 (save-excursion
4143 (set-buffer nntp-server-buffer) 4394 (set-buffer nntp-server-buffer)
4144 ;; Translate all TAB characters into SPACE characters. 4395 ;; Translate all TAB characters into SPACE characters.
4145 (subst-char-in-region (point-min) (point-max) ?\t ? t) 4396 (subst-char-in-region (point-min) (point-max) ?\t ? t)
4146 (run-hooks 'gnus-parse-headers-hook) 4397 (gnus-run-hooks 'gnus-parse-headers-hook)
4147 (let ((case-fold-search t) 4398 (let ((case-fold-search t)
4148 in-reply-to header p lines) 4399 in-reply-to header p lines chars)
4149 (goto-char (point-min)) 4400 (goto-char (point-min))
4150 ;; Search to the beginning of the next header. Error messages 4401 ;; Search to the beginning of the next header. Error messages
4151 ;; do not begin with 2 or 3. 4402 ;; do not begin with 2 or 3.
@@ -4174,7 +4425,6 @@ The resulting hash table is returned, or nil if no Xrefs were found."
4174 (progn 4425 (progn
4175 (goto-char p) 4426 (goto-char p)
4176 (if (search-forward "\nsubject: " nil t) 4427 (if (search-forward "\nsubject: " nil t)
4177 ;; 1997/5/4 by MORIOKA Tomohiko <morioka@jaist.ac.jp>
4178 (funcall 4428 (funcall
4179 gnus-unstructured-field-decoder (nnheader-header-value)) 4429 gnus-unstructured-field-decoder (nnheader-header-value))
4180 "(none)")) 4430 "(none)"))
@@ -4182,7 +4432,6 @@ The resulting hash table is returned, or nil if no Xrefs were found."
4182 (progn 4432 (progn
4183 (goto-char p) 4433 (goto-char p)
4184 (if (search-forward "\nfrom: " nil t) 4434 (if (search-forward "\nfrom: " nil t)
4185 ;; 1997/5/4 by MORIOKA Tomohiko <morioka@jaist.ac.jp>
4186 (funcall 4435 (funcall
4187 gnus-structured-field-decoder (nnheader-header-value)) 4436 gnus-structured-field-decoder (nnheader-header-value))
4188 "(nobody)")) 4437 "(nobody)"))
@@ -4194,10 +4443,12 @@ The resulting hash table is returned, or nil if no Xrefs were found."
4194 ;; Message-ID. 4443 ;; Message-ID.
4195 (progn 4444 (progn
4196 (goto-char p) 4445 (goto-char p)
4197 (setq id (if (search-forward "\nmessage-id:" nil t) 4446 (setq id (if (re-search-forward
4198 (buffer-substring 4447 "^message-id: *\\(<[^\n\t> ]+>\\)" nil t)
4199 (1- (or (search-forward "<" nil t) (point))) 4448 ;; We do it this way to make sure the Message-ID
4200 (or (search-forward ">" nil t) (point))) 4449 ;; is (somewhat) syntactically valid.
4450 (buffer-substring (match-beginning 1)
4451 (match-end 1))
4201 ;; If there was no message-id, we just fake one 4452 ;; If there was no message-id, we just fake one
4202 ;; to make subsequent routines simpler. 4453 ;; to make subsequent routines simpler.
4203 (nnheader-generate-fake-message-id)))) 4454 (nnheader-generate-fake-message-id))))
@@ -4224,11 +4475,23 @@ The resulting hash table is returned, or nil if no Xrefs were found."
4224 (if (and (search-forward "\nin-reply-to: " nil t) 4475 (if (and (search-forward "\nin-reply-to: " nil t)
4225 (setq in-reply-to (nnheader-header-value)) 4476 (setq in-reply-to (nnheader-header-value))
4226 (string-match "<[^>]+>" in-reply-to)) 4477 (string-match "<[^>]+>" in-reply-to))
4227 (setq ref (substring in-reply-to (match-beginning 0) 4478 (let (ref2)
4228 (match-end 0))) 4479 (setq ref (substring in-reply-to (match-beginning 0)
4480 (match-end 0)))
4481 (while (string-match "<[^>]+>" in-reply-to (match-end 0))
4482 (setq ref2 (substring in-reply-to (match-beginning 0)
4483 (match-end 0)))
4484 (when (> (length ref2) (length ref))
4485 (setq ref ref2)))
4486 ref)
4229 (setq ref nil)))) 4487 (setq ref nil))))
4230 ;; Chars. 4488 ;; Chars.
4231 0 4489 (progn
4490 (goto-char p)
4491 (if (search-forward "\nchars: " nil t)
4492 (if (numberp (setq chars (ignore-errors (read cur))))
4493 chars 0)
4494 0))
4232 ;; Lines. 4495 ;; Lines.
4233 (progn 4496 (progn
4234 (goto-char p) 4497 (goto-char p)
@@ -4243,146 +4506,20 @@ The resulting hash table is returned, or nil if no Xrefs were found."
4243 (nnheader-header-value))))) 4506 (nnheader-header-value)))))
4244 (when (equal id ref) 4507 (when (equal id ref)
4245 (setq ref nil)) 4508 (setq ref nil))
4246 ;; We do the threading while we read the headers. The 4509
4247 ;; message-id and the last reference are both entered into 4510 (when gnus-alter-header-function
4248 ;; the same hash table. Some tippy-toeing around has to be 4511 (funcall gnus-alter-header-function header)
4249 ;; done in case an article has arrived before the article 4512 (setq id (mail-header-id header)
4250 ;; which it refers to. 4513 ref (gnus-parent-id (mail-header-references header))))
4251 (if (boundp (setq id-dep (intern id dependencies))) 4514
4252 (if (and (car (symbol-value id-dep)) 4515 (when (setq header
4253 (not force-new)) 4516 (gnus-dependencies-add-header
4254 ;; An article with this Message-ID has already been seen. 4517 header dependencies force-new))
4255 (if gnus-summary-ignore-duplicates
4256 ;; We ignore this one, except we add
4257 ;; any additional Xrefs (in case the two articles
4258 ;; came from different servers).
4259 (progn
4260 (mail-header-set-xref
4261 (car (symbol-value id-dep))
4262 (concat (or (mail-header-xref
4263 (car (symbol-value id-dep)))
4264 "")
4265 (or (mail-header-xref header) "")))
4266 (setq header nil))
4267 ;; We rename the Message-ID.
4268 (set
4269 (setq id-dep (intern (setq id (nnmail-message-id))
4270 dependencies))
4271 (list header))
4272 (mail-header-set-id header id))
4273 (setcar (symbol-value id-dep) header))
4274 (set id-dep (list header)))
4275 (when header
4276 (if (boundp (setq ref-dep (intern (or ref "none") dependencies)))
4277 (setcdr (symbol-value ref-dep)
4278 (nconc (cdr (symbol-value ref-dep))
4279 (list (symbol-value id-dep))))
4280 (set ref-dep (list nil (symbol-value id-dep))))
4281 (push header headers)) 4518 (push header headers))
4282 (goto-char (point-max)) 4519 (goto-char (point-max))
4283 (widen)) 4520 (widen))
4284 (nreverse headers))))) 4521 (nreverse headers)))))
4285 4522
4286;; The following macros and functions were written by Felix Lee
4287;; <flee@cse.psu.edu>.
4288
4289(defmacro gnus-nov-read-integer ()
4290 '(prog1
4291 (if (= (following-char) ?\t)
4292 0
4293 (let ((num (ignore-errors (read buffer))))
4294 (if (numberp num) num 0)))
4295 (unless (eobp)
4296 (forward-char 1))))
4297
4298(defmacro gnus-nov-skip-field ()
4299 '(search-forward "\t" eol 'move))
4300
4301(defmacro gnus-nov-field ()
4302 '(buffer-substring (point) (if (gnus-nov-skip-field) (1- (point)) eol)))
4303
4304;; (defvar gnus-nov-none-counter 0)
4305
4306;; This function has to be called with point after the article number
4307;; on the beginning of the line.
4308(defun gnus-nov-parse-line (number dependencies &optional force-new)
4309 (let ((eol (gnus-point-at-eol))
4310 (buffer (current-buffer))
4311 header ref id id-dep ref-dep)
4312
4313 ;; overview: [num subject from date id refs chars lines misc]
4314 (unwind-protect
4315 (progn
4316 (narrow-to-region (point) eol)
4317 (unless (eobp)
4318 (forward-char))
4319
4320 (setq header
4321 (vector
4322 number ; number
4323 ;; 1997/5/4 by MORIOKA Tomohiko <morioka@jaist.ac.jp>
4324 (funcall
4325 gnus-unstructured-field-decoder (gnus-nov-field)) ; subject
4326 (funcall
4327 gnus-structured-field-decoder (gnus-nov-field)) ; from
4328 (gnus-nov-field) ; date
4329 (setq id (or (gnus-nov-field)
4330 (nnheader-generate-fake-message-id))) ; id
4331 (progn
4332 (let ((beg (point)))
4333 (search-forward "\t" eol)
4334 (if (search-backward ">" beg t)
4335 (setq ref
4336 (buffer-substring
4337 (1+ (point))
4338 (search-backward "<" beg t)))
4339 (setq ref nil))
4340 (goto-char beg))
4341 (gnus-nov-field)) ; refs
4342 (gnus-nov-read-integer) ; chars
4343 (gnus-nov-read-integer) ; lines
4344 (if (= (following-char) ?\n)
4345 nil
4346 (gnus-nov-field))))) ; misc
4347
4348 (widen))
4349
4350 ;; We build the thread tree.
4351 (when (equal id ref)
4352 ;; This article refers back to itself. Naughty, naughty.
4353 (setq ref nil))
4354 (if (boundp (setq id-dep (intern id dependencies)))
4355 (if (and (car (symbol-value id-dep))
4356 (not force-new))
4357 ;; An article with this Message-ID has already been seen.
4358 (if gnus-summary-ignore-duplicates
4359 ;; We ignore this one, except we add any additional
4360 ;; Xrefs (in case the two articles came from different
4361 ;; servers.
4362 (progn
4363 (mail-header-set-xref
4364 (car (symbol-value id-dep))
4365 (concat (or (mail-header-xref
4366 (car (symbol-value id-dep)))
4367 "")
4368 (or (mail-header-xref header) "")))
4369 (setq header nil))
4370 ;; We rename the Message-ID.
4371 (set
4372 (setq id-dep (intern (setq id (nnmail-message-id))
4373 dependencies))
4374 (list header))
4375 (mail-header-set-id header id))
4376 (setcar (symbol-value id-dep) header))
4377 (set id-dep (list header)))
4378 (when header
4379 (if (boundp (setq ref-dep (intern (or ref "none") dependencies)))
4380 (setcdr (symbol-value ref-dep)
4381 (nconc (cdr (symbol-value ref-dep))
4382 (list (symbol-value id-dep))))
4383 (set ref-dep (list nil (symbol-value id-dep)))))
4384 header))
4385
4386;; Goes through the xover lines and returns a list of vectors 4523;; Goes through the xover lines and returns a list of vectors
4387(defun gnus-get-newsgroup-headers-xover (sequence &optional 4524(defun gnus-get-newsgroup-headers-xover (sequence &optional
4388 force-new dependencies 4525 force-new dependencies
@@ -4398,7 +4535,7 @@ list of headers that match SEQUENCE (see `nntp-retrieve-headers')."
4398 (save-excursion 4535 (save-excursion
4399 (set-buffer nntp-server-buffer) 4536 (set-buffer nntp-server-buffer)
4400 ;; Allow the user to mangle the headers before parsing them. 4537 ;; Allow the user to mangle the headers before parsing them.
4401 (run-hooks 'gnus-parse-headers-hook) 4538 (gnus-run-hooks 'gnus-parse-headers-hook)
4402 (goto-char (point-min)) 4539 (goto-char (point-min))
4403 (while (not (eobp)) 4540 (while (not (eobp))
4404 (condition-case () 4541 (condition-case ()
@@ -4459,17 +4596,27 @@ This is meant to be called in `gnus-article-internal-prepare-hook'."
4459 (mail-header-set-xref headers xref))))))) 4596 (mail-header-set-xref headers xref)))))))
4460 4597
4461(defun gnus-summary-insert-subject (id &optional old-header use-old-header) 4598(defun gnus-summary-insert-subject (id &optional old-header use-old-header)
4462 "Find article ID and insert the summary line for that article." 4599 "Find article ID and insert the summary line for that article.
4463 (let ((header (if (and old-header use-old-header) 4600OLD-HEADER can either be a header or a line number to insert
4464 old-header (gnus-read-header id))) 4601the subject line on."
4602 (let* ((line (and (numberp old-header) old-header))
4603 (old-header (and (vectorp old-header) old-header))
4604 (header (cond ((and old-header use-old-header)
4605 old-header)
4606 ((and (numberp id)
4607 (gnus-number-to-header id))
4608 (gnus-number-to-header id))
4609 (t
4610 (gnus-read-header id))))
4465 (number (and (numberp id) id)) 4611 (number (and (numberp id) id))
4466 pos d) 4612 d)
4467 (when header 4613 (when header
4468 ;; Rebuild the thread that this article is part of and go to the 4614 ;; Rebuild the thread that this article is part of and go to the
4469 ;; article we have fetched. 4615 ;; article we have fetched.
4470 (when (and (not gnus-show-threads) 4616 (when (and (not gnus-show-threads)
4471 old-header) 4617 old-header)
4472 (when (setq d (gnus-data-find (mail-header-number old-header))) 4618 (when (and number
4619 (setq d (gnus-data-find (mail-header-number old-header))))
4473 (goto-char (gnus-data-pos d)) 4620 (goto-char (gnus-data-pos d))
4474 (gnus-data-remove 4621 (gnus-data-remove
4475 number 4622 number
@@ -4483,7 +4630,8 @@ This is meant to be called in `gnus-article-internal-prepare-hook'."
4483 (delq (setq number (mail-header-number header)) 4630 (delq (setq number (mail-header-number header))
4484 gnus-newsgroup-sparse)) 4631 gnus-newsgroup-sparse))
4485 (setq gnus-newsgroup-ancient (delq number gnus-newsgroup-ancient)) 4632 (setq gnus-newsgroup-ancient (delq number gnus-newsgroup-ancient))
4486 (gnus-rebuild-thread (mail-header-id header)) 4633 (push number gnus-newsgroup-limit)
4634 (gnus-rebuild-thread (mail-header-id header) line)
4487 (gnus-summary-goto-subject number nil t)) 4635 (gnus-summary-goto-subject number nil t))
4488 (when (and (numberp number) 4636 (when (and (numberp number)
4489 (> number 0)) 4637 (> number 0))
@@ -4503,47 +4651,63 @@ This is meant to be called in `gnus-article-internal-prepare-hook'."
4503;;; Process/prefix in the summary buffer 4651;;; Process/prefix in the summary buffer
4504 4652
4505(defun gnus-summary-work-articles (n) 4653(defun gnus-summary-work-articles (n)
4506 "Return a list of articles to be worked upon. The prefix argument, 4654 "Return a list of articles to be worked upon.
4507the list of process marked articles, and the current article will be 4655The prefix argument, the list of process marked articles, and the
4508taken into consideration." 4656current article will be taken into consideration."
4509 (cond 4657 (save-excursion
4510 (n 4658 (set-buffer gnus-summary-buffer)
4511 ;; A numerical prefix has been given. 4659 (cond
4512 (setq n (prefix-numeric-value n)) 4660 (n
4513 (let ((backward (< n 0)) 4661 ;; A numerical prefix has been given.
4514 (n (abs (prefix-numeric-value n))) 4662 (setq n (prefix-numeric-value n))
4515 articles article) 4663 (let ((backward (< n 0))
4516 (save-excursion 4664 (n (abs (prefix-numeric-value n)))
4517 (while 4665 articles article)
4518 (and (> n 0) 4666 (save-excursion
4519 (push (setq article (gnus-summary-article-number)) 4667 (while
4520 articles) 4668 (and (> n 0)
4521 (if backward 4669 (push (setq article (gnus-summary-article-number))
4522 (gnus-summary-find-prev nil article) 4670 articles)
4523 (gnus-summary-find-next nil article))) 4671 (if backward
4524 (decf n))) 4672 (gnus-summary-find-prev nil article)
4525 (nreverse articles))) 4673 (gnus-summary-find-next nil article)))
4526 ((gnus-region-active-p) 4674 (decf n)))
4527 ;; Work on the region between point and mark. 4675 (nreverse articles)))
4528 (let ((max (max (point) (mark))) 4676 ((and (gnus-region-active-p) (mark))
4529 articles article) 4677 (message "region active")
4530 (save-excursion 4678 ;; Work on the region between point and mark.
4531 (goto-char (min (point) (mark))) 4679 (let ((max (max (point) (mark)))
4532 (while 4680 articles article)
4533 (and 4681 (save-excursion
4534 (push (setq article (gnus-summary-article-number)) articles) 4682 (goto-char (min (min (point) (mark))))
4535 (gnus-summary-find-next nil article) 4683 (while
4536 (< (point) max))) 4684 (and
4537 (nreverse articles)))) 4685 (push (setq article (gnus-summary-article-number)) articles)
4538 (gnus-newsgroup-processable 4686 (gnus-summary-find-next nil article)
4539 ;; There are process-marked articles present. 4687 (< (point) max)))
4540 ;; Save current state. 4688 (nreverse articles))))
4541 (gnus-summary-save-process-mark) 4689 (gnus-newsgroup-processable
4542 ;; Return the list. 4690 ;; There are process-marked articles present.
4543 (reverse gnus-newsgroup-processable)) 4691 ;; Save current state.
4544 (t 4692 (gnus-summary-save-process-mark)
4545 ;; Just return the current article. 4693 ;; Return the list.
4546 (list (gnus-summary-article-number))))) 4694 (reverse gnus-newsgroup-processable))
4695 (t
4696 ;; Just return the current article.
4697 (list (gnus-summary-article-number))))))
4698
4699(defmacro gnus-summary-iterate (arg &rest forms)
4700 "Iterate over the process/prefixed articles and do FORMS.
4701ARG is the interactive prefix given to the command. FORMS will be
4702executed with point over the summary line of the articles."
4703 (let ((articles (make-symbol "gnus-summary-iterate-articles")))
4704 `(let ((,articles (gnus-summary-work-articles ,arg)))
4705 (while ,articles
4706 (gnus-summary-goto-subject (car ,articles))
4707 ,@forms))))
4708
4709(put 'gnus-summary-iterate 'lisp-indent-function 1)
4710(put 'gnus-summary-iterate 'edebug-form-spec '(form body))
4547 4711
4548(defun gnus-summary-save-process-mark () 4712(defun gnus-summary-save-process-mark ()
4549 "Push the current set of process marked articles on the stack." 4713 "Push the current set of process marked articles on the stack."
@@ -4589,7 +4753,7 @@ If EXCLUDE-GROUP, do not go to this group."
4589 (save-excursion 4753 (save-excursion
4590 (gnus-group-best-unread-group exclude-group)))) 4754 (gnus-group-best-unread-group exclude-group))))
4591 4755
4592(defun gnus-summary-find-next (&optional unread article backward) 4756(defun gnus-summary-find-next (&optional unread article backward undownloaded)
4593 (if backward (gnus-summary-find-prev) 4757 (if backward (gnus-summary-find-prev)
4594 (let* ((dummy (gnus-summary-article-intangible-p)) 4758 (let* ((dummy (gnus-summary-article-intangible-p))
4595 (article (or article (gnus-summary-article-number))) 4759 (article (or article (gnus-summary-article-number)))
@@ -4604,7 +4768,10 @@ If EXCLUDE-GROUP, do not go to this group."
4604 (if unread 4768 (if unread
4605 (progn 4769 (progn
4606 (while arts 4770 (while arts
4607 (when (gnus-data-unread-p (car arts)) 4771 (when (or (and undownloaded
4772 (eq gnus-undownloaded-mark
4773 (gnus-data-mark (car arts))))
4774 (gnus-data-unread-p (car arts)))
4608 (setq result (car arts) 4775 (setq result (car arts)
4609 arts nil)) 4776 arts nil))
4610 (setq arts (cdr arts))) 4777 (setq arts (cdr arts)))
@@ -4740,12 +4907,12 @@ displayed, no centering will be performed."
4740 ;; first unread article is the article after the last read 4907 ;; first unread article is the article after the last read
4741 ;; article. Sounds logical, doesn't it? 4908 ;; article. Sounds logical, doesn't it?
4742 (if (not (listp (cdr read))) 4909 (if (not (listp (cdr read)))
4743 (setq first (1+ (cdr read))) 4910 (setq first (max (car active) (1+ (cdr read))))
4744 ;; `read' is a list of ranges. 4911 ;; `read' is a list of ranges.
4745 (when (/= (setq nlast (or (and (numberp (car read)) (car read)) 4912 (when (/= (setq nlast (or (and (numberp (car read)) (car read))
4746 (caar read))) 4913 (caar read)))
4747 1) 4914 1)
4748 (setq first 1)) 4915 (setq first (car active)))
4749 (while read 4916 (while read
4750 (when first 4917 (when first
4751 (while (< first nlast) 4918 (while (< first nlast)
@@ -4759,7 +4926,7 @@ displayed, no centering will be performed."
4759 (push first unread) 4926 (push first unread)
4760 (setq first (1+ first))) 4927 (setq first (1+ first)))
4761 ;; Return the list of unread articles. 4928 ;; Return the list of unread articles.
4762 (nreverse unread))) 4929 (delq 0 (nreverse unread))))
4763 4930
4764(defun gnus-list-of-read-articles (group) 4931(defun gnus-list-of-read-articles (group)
4765 "Return a list of unread, unticked and non-dormant articles." 4932 "Return a list of unread, unticked and non-dormant articles."
@@ -4777,10 +4944,17 @@ displayed, no centering will be performed."
4777 4944
4778;; Various summary commands 4945;; Various summary commands
4779 4946
4947(defun gnus-summary-select-article-buffer ()
4948 "Reconfigure windows to show article buffer."
4949 (interactive)
4950 (if (not (gnus-buffer-live-p gnus-article-buffer))
4951 (error "There is no article buffer for this summary buffer")
4952 (gnus-configure-windows 'article)
4953 (select-window (get-buffer-window gnus-article-buffer))))
4954
4780(defun gnus-summary-universal-argument (arg) 4955(defun gnus-summary-universal-argument (arg)
4781 "Perform any operation on all articles that are process/prefixed." 4956 "Perform any operation on all articles that are process/prefixed."
4782 (interactive "P") 4957 (interactive "P")
4783 (gnus-set-global-variables)
4784 (let ((articles (gnus-summary-work-articles arg)) 4958 (let ((articles (gnus-summary-work-articles arg))
4785 func article) 4959 func article)
4786 (if (eq 4960 (if (eq
@@ -4814,7 +4988,6 @@ With arg, turn line truncation on iff arg is positive."
4814 "Exit and then reselect the current newsgroup. 4988 "Exit and then reselect the current newsgroup.
4815The prefix argument ALL means to select all articles." 4989The prefix argument ALL means to select all articles."
4816 (interactive "P") 4990 (interactive "P")
4817 (gnus-set-global-variables)
4818 (when (gnus-ephemeral-group-p gnus-newsgroup-name) 4991 (when (gnus-ephemeral-group-p gnus-newsgroup-name)
4819 (error "Ephemeral groups can't be reselected")) 4992 (error "Ephemeral groups can't be reselected"))
4820 (let ((current-subject (gnus-summary-article-number)) 4993 (let ((current-subject (gnus-summary-article-number))
@@ -4838,43 +5011,42 @@ The prefix argument ALL means to select all articles."
4838(defun gnus-summary-update-info (&optional non-destructive) 5011(defun gnus-summary-update-info (&optional non-destructive)
4839 (save-excursion 5012 (save-excursion
4840 (let ((group gnus-newsgroup-name)) 5013 (let ((group gnus-newsgroup-name))
4841 (when gnus-newsgroup-kill-headers 5014 (when group
4842 (setq gnus-newsgroup-killed 5015 (when gnus-newsgroup-kill-headers
4843 (gnus-compress-sequence 5016 (setq gnus-newsgroup-killed
4844 (nconc 5017 (gnus-compress-sequence
4845 (gnus-set-sorted-intersection 5018 (nconc
4846 (gnus-uncompress-range gnus-newsgroup-killed) 5019 (gnus-set-sorted-intersection
4847 (setq gnus-newsgroup-unselected 5020 (gnus-uncompress-range gnus-newsgroup-killed)
4848 (sort gnus-newsgroup-unselected '<))) 5021 (setq gnus-newsgroup-unselected
4849 (setq gnus-newsgroup-unreads 5022 (sort gnus-newsgroup-unselected '<)))
4850 (sort gnus-newsgroup-unreads '<))) 5023 (setq gnus-newsgroup-unreads
4851 t))) 5024 (sort gnus-newsgroup-unreads '<)))
4852 (unless (listp (cdr gnus-newsgroup-killed)) 5025 t)))
4853 (setq gnus-newsgroup-killed (list gnus-newsgroup-killed))) 5026 (unless (listp (cdr gnus-newsgroup-killed))
4854 (let ((headers gnus-newsgroup-headers)) 5027 (setq gnus-newsgroup-killed (list gnus-newsgroup-killed)))
4855 (when (and (not gnus-save-score) 5028 (let ((headers gnus-newsgroup-headers))
4856 (not non-destructive)) 5029 ;; Set the new ranges of read articles.
4857 (setq gnus-newsgroup-scored nil)) 5030 (save-excursion
4858 ;; Set the new ranges of read articles. 5031 (set-buffer gnus-group-buffer)
4859 (save-excursion 5032 (gnus-undo-force-boundary))
5033 (gnus-update-read-articles
5034 group (append gnus-newsgroup-unreads gnus-newsgroup-unselected))
5035 ;; Set the current article marks.
5036 (let ((gnus-newsgroup-scored
5037 (if (and (not gnus-save-score)
5038 (not non-destructive))
5039 nil
5040 gnus-newsgroup-scored)))
5041 (save-excursion
5042 (gnus-update-marks)))
5043 ;; Do the cross-ref thing.
5044 (when gnus-use-cross-reference
5045 (gnus-mark-xrefs-as-read group headers gnus-newsgroup-unreads))
5046 ;; Do not switch windows but change the buffer to work.
4860 (set-buffer gnus-group-buffer) 5047 (set-buffer gnus-group-buffer)
4861 (gnus-undo-force-boundary)) 5048 (unless (gnus-ephemeral-group-p group)
4862 (gnus-update-read-articles 5049 (gnus-group-update-group group)))))))
4863 group (append gnus-newsgroup-unreads gnus-newsgroup-unselected))
4864 ;; Set the current article marks.
4865 (gnus-update-marks)
4866 ;; Do the cross-ref thing.
4867 (when gnus-use-cross-reference
4868 (gnus-mark-xrefs-as-read group headers gnus-newsgroup-unreads))
4869 ;; Do adaptive scoring, and possibly save score files.
4870 (when gnus-newsgroup-adaptive
4871 (gnus-score-adaptive))
4872 (when gnus-use-scoring
4873 (gnus-score-save))
4874 ;; Do not switch windows but change the buffer to work.
4875 (set-buffer gnus-group-buffer)
4876 (unless (gnus-ephemeral-group-p gnus-newsgroup-name)
4877 (gnus-group-update-group group))))))
4878 5050
4879(defun gnus-summary-save-newsrc (&optional force) 5051(defun gnus-summary-save-newsrc (&optional force)
4880 "Save the current number of read/marked articles in the dribble buffer. 5052 "Save the current number of read/marked articles in the dribble buffer.
@@ -4892,12 +5064,13 @@ gnus-exit-group-hook is called with no arguments if that value is non-nil."
4892 (interactive) 5064 (interactive)
4893 (gnus-set-global-variables) 5065 (gnus-set-global-variables)
4894 (gnus-kill-save-kill-buffer) 5066 (gnus-kill-save-kill-buffer)
5067 (gnus-async-halt-prefetch)
4895 (let* ((group gnus-newsgroup-name) 5068 (let* ((group gnus-newsgroup-name)
4896 (quit-config (gnus-group-quit-config gnus-newsgroup-name)) 5069 (quit-config (gnus-group-quit-config gnus-newsgroup-name))
4897 (mode major-mode) 5070 (mode major-mode)
4898 (group-point nil) 5071 (group-point nil)
4899 (buf (current-buffer))) 5072 (buf (current-buffer)))
4900 (run-hooks 'gnus-summary-prepare-exit-hook) 5073 (gnus-run-hooks 'gnus-summary-prepare-exit-hook)
4901 ;; If we have several article buffers, we kill them at exit. 5074 ;; If we have several article buffers, we kill them at exit.
4902 (unless gnus-single-article-buffer 5075 (unless gnus-single-article-buffer
4903 (gnus-kill-buffer gnus-original-article-buffer) 5076 (gnus-kill-buffer gnus-original-article-buffer)
@@ -4910,17 +5083,27 @@ gnus-exit-group-hook is called with no arguments if that value is non-nil."
4910 (gnus-dup-enter-articles)) 5083 (gnus-dup-enter-articles))
4911 (when gnus-use-trees 5084 (when gnus-use-trees
4912 (gnus-tree-close group)) 5085 (gnus-tree-close group))
5086 ;; Remove entries for this group.
5087 (nnmail-purge-split-history (gnus-group-real-name group))
4913 ;; Make all changes in this group permanent. 5088 ;; Make all changes in this group permanent.
4914 (unless quit-config 5089 (unless quit-config
4915 (run-hooks 'gnus-exit-group-hook) 5090 (gnus-run-hooks 'gnus-exit-group-hook)
4916 (gnus-summary-update-info)) 5091 (gnus-summary-update-info)
5092 ;; Do adaptive scoring, and possibly save score files.
5093 (when gnus-newsgroup-adaptive
5094 (gnus-score-adaptive))
5095 (when gnus-use-scoring
5096 (gnus-score-save)))
4917 (gnus-close-group group) 5097 (gnus-close-group group)
4918 ;; Make sure where we were, and go to next newsgroup. 5098 ;; Make sure where we were, and go to next newsgroup.
4919 (set-buffer gnus-group-buffer) 5099 (set-buffer gnus-group-buffer)
4920 (unless quit-config 5100 (unless quit-config
4921 (gnus-group-jump-to-group group)) 5101 (gnus-group-jump-to-group group))
4922 (run-hooks 'gnus-summary-exit-hook) 5102 (gnus-run-hooks 'gnus-summary-exit-hook)
4923 (unless quit-config 5103 (unless (or quit-config
5104 ;; If this group has disappeared from the summary
5105 ;; buffer, don't skip forwards.
5106 (not (string= group (gnus-group-group-name))))
4924 (gnus-group-next-unread-group 1)) 5107 (gnus-group-next-unread-group 1))
4925 (setq group-point (point)) 5108 (setq group-point (point))
4926 (if temporary 5109 (if temporary
@@ -4949,12 +5132,12 @@ gnus-exit-group-hook is called with no arguments if that value is non-nil."
4949 (gnus-kill-buffer buf))) 5132 (gnus-kill-buffer buf)))
4950 (setq gnus-current-select-method gnus-select-method) 5133 (setq gnus-current-select-method gnus-select-method)
4951 (pop-to-buffer gnus-group-buffer) 5134 (pop-to-buffer gnus-group-buffer)
4952 ;; Clear the current group name.
4953 (if (not quit-config) 5135 (if (not quit-config)
4954 (progn 5136 (progn
4955 (goto-char group-point) 5137 (goto-char group-point)
4956 (gnus-configure-windows 'group 'force)) 5138 (gnus-configure-windows 'group 'force))
4957 (gnus-handle-ephemeral-exit quit-config)) 5139 (gnus-handle-ephemeral-exit quit-config))
5140 ;; Clear the current group name.
4958 (unless quit-config 5141 (unless quit-config
4959 (setq gnus-newsgroup-name nil))))) 5142 (setq gnus-newsgroup-name nil)))))
4960 5143
@@ -4962,12 +5145,13 @@ gnus-exit-group-hook is called with no arguments if that value is non-nil."
4962(defun gnus-summary-exit-no-update (&optional no-questions) 5145(defun gnus-summary-exit-no-update (&optional no-questions)
4963 "Quit reading current newsgroup without updating read article info." 5146 "Quit reading current newsgroup without updating read article info."
4964 (interactive) 5147 (interactive)
4965 (gnus-set-global-variables)
4966 (let* ((group gnus-newsgroup-name) 5148 (let* ((group gnus-newsgroup-name)
4967 (quit-config (gnus-group-quit-config group))) 5149 (quit-config (gnus-group-quit-config group)))
4968 (when (or no-questions 5150 (when (or no-questions
4969 gnus-expert-user 5151 gnus-expert-user
4970 (gnus-y-or-n-p "Discard changes to this group and exit? ")) 5152 (gnus-y-or-n-p "Discard changes to this group and exit? "))
5153 (gnus-async-halt-prefetch)
5154 (gnus-run-hooks 'gnus-summary-prepare-exit-hook)
4971 ;; If we have several article buffers, we kill them at exit. 5155 ;; If we have several article buffers, we kill them at exit.
4972 (unless gnus-single-article-buffer 5156 (unless gnus-single-article-buffer
4973 (gnus-kill-buffer gnus-article-buffer) 5157 (gnus-kill-buffer gnus-article-buffer)
@@ -4998,8 +5182,8 @@ gnus-exit-group-hook is called with no arguments if that value is non-nil."
4998 (gnus-handle-ephemeral-exit quit-config))))) 5182 (gnus-handle-ephemeral-exit quit-config)))))
4999 5183
5000(defun gnus-handle-ephemeral-exit (quit-config) 5184(defun gnus-handle-ephemeral-exit (quit-config)
5001 "Handle movement when leaving an ephemeral group. The state 5185 "Handle movement when leaving an ephemeral group.
5002which existed when entering the ephemeral is reset." 5186The state which existed when entering the ephemeral is reset."
5003 (if (not (buffer-name (car quit-config))) 5187 (if (not (buffer-name (car quit-config)))
5004 (gnus-configure-windows 'group 'force) 5188 (gnus-configure-windows 'group 'force)
5005 (set-buffer (car quit-config)) 5189 (set-buffer (car quit-config))
@@ -5079,25 +5263,24 @@ which existed when entering the ephemeral is reset."
5079 5263
5080(defun gnus-kill-or-deaden-summary (buffer) 5264(defun gnus-kill-or-deaden-summary (buffer)
5081 "Kill or deaden the summary BUFFER." 5265 "Kill or deaden the summary BUFFER."
5082 (when (and (buffer-name buffer) 5266 (save-excursion
5083 (not gnus-single-article-buffer)) 5267 (when (and (buffer-name buffer)
5084 (save-excursion 5268 (not gnus-single-article-buffer))
5085 (set-buffer buffer) 5269 (save-excursion
5086 (gnus-kill-buffer gnus-article-buffer) 5270 (set-buffer buffer)
5087 (gnus-kill-buffer gnus-original-article-buffer))) 5271 (gnus-kill-buffer gnus-article-buffer)
5088 (cond (gnus-kill-summary-on-exit 5272 (gnus-kill-buffer gnus-original-article-buffer)))
5089 (when (and gnus-use-trees 5273 (cond (gnus-kill-summary-on-exit
5090 (and (get-buffer buffer) 5274 (when (and gnus-use-trees
5091 (buffer-name (get-buffer buffer)))) 5275 (gnus-buffer-exists-p buffer))
5276 (save-excursion
5277 (set-buffer buffer)
5278 (gnus-tree-close gnus-newsgroup-name)))
5279 (gnus-kill-buffer buffer))
5280 ((gnus-buffer-exists-p buffer)
5092 (save-excursion 5281 (save-excursion
5093 (set-buffer (get-buffer buffer)) 5282 (set-buffer buffer)
5094 (gnus-tree-close gnus-newsgroup-name))) 5283 (gnus-deaden-summary))))))
5095 (gnus-kill-buffer buffer))
5096 ((and (get-buffer buffer)
5097 (buffer-name (get-buffer buffer)))
5098 (save-excursion
5099 (set-buffer buffer)
5100 (gnus-deaden-summary)))))
5101 5284
5102(defun gnus-summary-wake-up-the-dead (&rest args) 5285(defun gnus-summary-wake-up-the-dead (&rest args)
5103 "Wake up the dead summary buffer." 5286 "Wake up the dead summary buffer."
@@ -5148,7 +5331,6 @@ If prefix argument NO-ARTICLE is non-nil, no article is selected
5148initially. If NEXT-GROUP, go to this group. If BACKWARD, go to 5331initially. If NEXT-GROUP, go to this group. If BACKWARD, go to
5149previous group instead." 5332previous group instead."
5150 (interactive "P") 5333 (interactive "P")
5151 (gnus-set-global-variables)
5152 ;; Stop pre-fetching. 5334 ;; Stop pre-fetching.
5153 (gnus-async-halt-prefetch) 5335 (gnus-async-halt-prefetch)
5154 (let ((current-group gnus-newsgroup-name) 5336 (let ((current-group gnus-newsgroup-name)
@@ -5177,7 +5359,7 @@ previous group instead."
5177 (when (gnus-buffer-live-p current-buffer) 5359 (when (gnus-buffer-live-p current-buffer)
5178 (set-buffer current-buffer) 5360 (set-buffer current-buffer)
5179 (gnus-summary-exit)) 5361 (gnus-summary-exit))
5180 (run-hooks 'gnus-group-no-more-groups-hook)) 5362 (gnus-run-hooks 'gnus-group-no-more-groups-hook))
5181 ;; We try to enter the target group. 5363 ;; We try to enter the target group.
5182 (gnus-group-jump-to-group target-group) 5364 (gnus-group-jump-to-group target-group)
5183 (let ((unreads (gnus-group-group-unread))) 5365 (let ((unreads (gnus-group-group-unread)))
@@ -5185,7 +5367,8 @@ previous group instead."
5185 (and unreads (not (zerop unreads)))) 5367 (and unreads (not (zerop unreads))))
5186 (gnus-summary-read-group 5368 (gnus-summary-read-group
5187 target-group nil no-article 5369 target-group nil no-article
5188 (and (buffer-name current-buffer) current-buffer))) 5370 (and (buffer-name current-buffer) current-buffer)
5371 nil backward))
5189 (setq entered t) 5372 (setq entered t)
5190 (setq current-group target-group 5373 (setq current-group target-group
5191 target-group nil))))))) 5374 target-group nil)))))))
@@ -5198,7 +5381,7 @@ If prefix argument NO-ARTICLE is non-nil, no article is selected initially."
5198 5381
5199;; Walking around summary lines. 5382;; Walking around summary lines.
5200 5383
5201(defun gnus-summary-first-subject (&optional unread) 5384(defun gnus-summary-first-subject (&optional unread undownloaded)
5202 "Go to the first unread subject. 5385 "Go to the first unread subject.
5203If UNREAD is non-nil, go to the first unread article. 5386If UNREAD is non-nil, go to the first unread article.
5204Returns the article selected or nil if there are no unread articles." 5387Returns the article selected or nil if there are no unread articles."
@@ -5221,7 +5404,10 @@ Returns the article selected or nil if there are no unread articles."
5221 (t 5404 (t
5222 (let ((data gnus-newsgroup-data)) 5405 (let ((data gnus-newsgroup-data))
5223 (while (and data 5406 (while (and data
5224 (not (gnus-data-unread-p (car data)))) 5407 (and (not (and undownloaded
5408 (eq gnus-undownloaded-mark
5409 (gnus-data-mark (car data)))))
5410 (not (gnus-data-unread-p (car data)))))
5225 (setq data (cdr data))) 5411 (setq data (cdr data)))
5226 (when data 5412 (when data
5227 (goto-char (gnus-data-pos (car data))) 5413 (goto-char (gnus-data-pos (car data)))
@@ -5241,6 +5427,7 @@ returned."
5241 (if backward 5427 (if backward
5242 (gnus-summary-find-prev unread) 5428 (gnus-summary-find-prev unread)
5243 (gnus-summary-find-next unread))) 5429 (gnus-summary-find-next unread)))
5430 (gnus-summary-show-thread)
5244 (setq n (1- n))) 5431 (setq n (1- n)))
5245 (when (/= 0 n) 5432 (when (/= 0 n)
5246 (gnus-message 7 "No more%s articles" 5433 (gnus-message 7 "No more%s articles"
@@ -5275,7 +5462,10 @@ If FORCE, also allow jumping to articles not currently shown."
5275 ;; We read in the article if we have to. 5462 ;; We read in the article if we have to.
5276 (and (not data) 5463 (and (not data)
5277 force 5464 force
5278 (gnus-summary-insert-subject article (and (vectorp force) force) t) 5465 (gnus-summary-insert-subject
5466 article
5467 (if (or (numberp force) (vectorp force)) force)
5468 t)
5279 (setq data (gnus-data-find article))) 5469 (setq data (gnus-data-find article)))
5280 (goto-char b) 5470 (goto-char b)
5281 (if (not data) 5471 (if (not data)
@@ -5284,6 +5474,7 @@ If FORCE, also allow jumping to articles not currently shown."
5284 (gnus-message 3 "Can't find article %d" article)) 5474 (gnus-message 3 "Can't find article %d" article))
5285 nil) 5475 nil)
5286 (goto-char (gnus-data-pos data)) 5476 (goto-char (gnus-data-pos data))
5477 (gnus-summary-position-point)
5287 article))) 5478 article)))
5288 5479
5289;; Walking around summary lines with displaying articles. 5480;; Walking around summary lines with displaying articles.
@@ -5292,7 +5483,6 @@ If FORCE, also allow jumping to articles not currently shown."
5292 "Make the summary buffer take up the entire Emacs frame. 5483 "Make the summary buffer take up the entire Emacs frame.
5293Given a prefix, will force an `article' buffer configuration." 5484Given a prefix, will force an `article' buffer configuration."
5294 (interactive "P") 5485 (interactive "P")
5295 (gnus-set-global-variables)
5296 (if arg 5486 (if arg
5297 (gnus-configure-windows 'article 'force) 5487 (gnus-configure-windows 'article 'force)
5298 (gnus-configure-windows 'summary 'force))) 5488 (gnus-configure-windows 'summary 'force)))
@@ -5306,7 +5496,7 @@ Given a prefix, will force an `article' buffer configuration."
5306 (if gnus-summary-display-article-function 5496 (if gnus-summary-display-article-function
5307 (funcall gnus-summary-display-article-function article all-header) 5497 (funcall gnus-summary-display-article-function article all-header)
5308 (gnus-article-prepare article all-header)) 5498 (gnus-article-prepare article all-header))
5309 (run-hooks 'gnus-select-article-hook) 5499 (gnus-run-hooks 'gnus-select-article-hook)
5310 (when (and gnus-current-article 5500 (when (and gnus-current-article
5311 (not (zerop gnus-current-article))) 5501 (not (zerop gnus-current-article)))
5312 (gnus-summary-goto-subject gnus-current-article)) 5502 (gnus-summary-goto-subject gnus-current-article))
@@ -5369,7 +5559,6 @@ If UNREAD, only unread articles are selected.
5369If SUBJECT, only articles with SUBJECT are selected. 5559If SUBJECT, only articles with SUBJECT are selected.
5370If BACKWARD, the previous article is selected instead of the next." 5560If BACKWARD, the previous article is selected instead of the next."
5371 (interactive "P") 5561 (interactive "P")
5372 (gnus-set-global-variables)
5373 (cond 5562 (cond
5374 ;; Is there such an article? 5563 ;; Is there such an article?
5375 ((and (gnus-summary-search-forward unread subject backward) 5564 ((and (gnus-summary-search-forward unread subject backward)
@@ -5387,7 +5576,7 @@ If BACKWARD, the previous article is selected instead of the next."
5387 (not unread) (not subject)) 5576 (not unread) (not subject))
5388 (gnus-summary-goto-article 5577 (gnus-summary-goto-article
5389 (if backward (1- gnus-newsgroup-begin) (1+ gnus-newsgroup-end)) 5578 (if backward (1- gnus-newsgroup-begin) (1+ gnus-newsgroup-end))
5390 nil t)) 5579 nil (count-lines (point-min) (point))))
5391 ;; Go to next/previous group. 5580 ;; Go to next/previous group.
5392 (t 5581 (t
5393 (unless (gnus-ephemeral-group-p gnus-newsgroup-name) 5582 (unless (gnus-ephemeral-group-p gnus-newsgroup-name)
@@ -5509,6 +5698,9 @@ article."
5509 (let ((article (gnus-summary-article-number)) 5698 (let ((article (gnus-summary-article-number))
5510 (article-window (get-buffer-window gnus-article-buffer t)) 5699 (article-window (get-buffer-window gnus-article-buffer t))
5511 endp) 5700 endp)
5701 ;; If the buffer is empty, we have no article.
5702 (unless article
5703 (error "No article to select"))
5512 (gnus-configure-windows 'article) 5704 (gnus-configure-windows 'article)
5513 (if (eq (cdr (assq article gnus-newsgroup-reads)) gnus-canceled-mark) 5705 (if (eq (cdr (assq article gnus-newsgroup-reads)) gnus-canceled-mark)
5514 (if (and (eq gnus-summary-goto-unread 'never) 5706 (if (and (eq gnus-summary-goto-unread 'never)
@@ -5543,7 +5735,6 @@ Argument LINES specifies lines to be scrolled down.
5543If MOVE, move to the previous unread article if point is at 5735If MOVE, move to the previous unread article if point is at
5544the beginning of the buffer." 5736the beginning of the buffer."
5545 (interactive "P") 5737 (interactive "P")
5546 (gnus-set-global-variables)
5547 (let ((article (gnus-summary-article-number)) 5738 (let ((article (gnus-summary-article-number))
5548 (article-window (get-buffer-window gnus-article-buffer t)) 5739 (article-window (get-buffer-window gnus-article-buffer t))
5549 endp) 5740 endp)
@@ -5579,7 +5770,6 @@ If at the beginning of the article, go to the next article."
5579 "Scroll up (or down) one line current article. 5770 "Scroll up (or down) one line current article.
5580Argument LINES specifies lines to be scrolled up (or down if negative)." 5771Argument LINES specifies lines to be scrolled up (or down if negative)."
5581 (interactive "p") 5772 (interactive "p")
5582 (gnus-set-global-variables)
5583 (gnus-configure-windows 'article) 5773 (gnus-configure-windows 'article)
5584 (gnus-summary-show-thread) 5774 (gnus-summary-show-thread)
5585 (when (eq (gnus-summary-select-article nil nil 'pseudo) 'old) 5775 (when (eq (gnus-summary-select-article nil nil 'pseudo) 'old)
@@ -5592,35 +5782,36 @@ Argument LINES specifies lines to be scrolled up (or down if negative)."
5592 (gnus-summary-recenter) 5782 (gnus-summary-recenter)
5593 (gnus-summary-position-point)) 5783 (gnus-summary-position-point))
5594 5784
5785(defun gnus-summary-scroll-down (lines)
5786 "Scroll down (or up) one line current article.
5787Argument LINES specifies lines to be scrolled down (or up if negative)."
5788 (interactive "p")
5789 (gnus-summary-scroll-up (- lines)))
5790
5595(defun gnus-summary-next-same-subject () 5791(defun gnus-summary-next-same-subject ()
5596 "Select next article which has the same subject as current one." 5792 "Select next article which has the same subject as current one."
5597 (interactive) 5793 (interactive)
5598 (gnus-set-global-variables)
5599 (gnus-summary-next-article nil (gnus-summary-article-subject))) 5794 (gnus-summary-next-article nil (gnus-summary-article-subject)))
5600 5795
5601(defun gnus-summary-prev-same-subject () 5796(defun gnus-summary-prev-same-subject ()
5602 "Select previous article which has the same subject as current one." 5797 "Select previous article which has the same subject as current one."
5603 (interactive) 5798 (interactive)
5604 (gnus-set-global-variables)
5605 (gnus-summary-prev-article nil (gnus-summary-article-subject))) 5799 (gnus-summary-prev-article nil (gnus-summary-article-subject)))
5606 5800
5607(defun gnus-summary-next-unread-same-subject () 5801(defun gnus-summary-next-unread-same-subject ()
5608 "Select next unread article which has the same subject as current one." 5802 "Select next unread article which has the same subject as current one."
5609 (interactive) 5803 (interactive)
5610 (gnus-set-global-variables)
5611 (gnus-summary-next-article t (gnus-summary-article-subject))) 5804 (gnus-summary-next-article t (gnus-summary-article-subject)))
5612 5805
5613(defun gnus-summary-prev-unread-same-subject () 5806(defun gnus-summary-prev-unread-same-subject ()
5614 "Select previous unread article which has the same subject as current one." 5807 "Select previous unread article which has the same subject as current one."
5615 (interactive) 5808 (interactive)
5616 (gnus-set-global-variables)
5617 (gnus-summary-prev-article t (gnus-summary-article-subject))) 5809 (gnus-summary-prev-article t (gnus-summary-article-subject)))
5618 5810
5619(defun gnus-summary-first-unread-article () 5811(defun gnus-summary-first-unread-article ()
5620 "Select the first unread article. 5812 "Select the first unread article.
5621Return nil if there are no unread articles." 5813Return nil if there are no unread articles."
5622 (interactive) 5814 (interactive)
5623 (gnus-set-global-variables)
5624 (prog1 5815 (prog1
5625 (when (gnus-summary-first-subject t) 5816 (when (gnus-summary-first-subject t)
5626 (gnus-summary-show-thread) 5817 (gnus-summary-show-thread)
@@ -5632,7 +5823,6 @@ Return nil if there are no unread articles."
5632 "Select the first article. 5823 "Select the first article.
5633Return nil if there are no articles." 5824Return nil if there are no articles."
5634 (interactive) 5825 (interactive)
5635 (gnus-set-global-variables)
5636 (prog1 5826 (prog1
5637 (when (gnus-summary-first-subject) 5827 (when (gnus-summary-first-subject)
5638 (gnus-summary-show-thread) 5828 (gnus-summary-show-thread)
@@ -5643,7 +5833,6 @@ Return nil if there are no articles."
5643(defun gnus-summary-best-unread-article () 5833(defun gnus-summary-best-unread-article ()
5644 "Select the unread article with the highest score." 5834 "Select the unread article with the highest score."
5645 (interactive) 5835 (interactive)
5646 (gnus-set-global-variables)
5647 (let ((best -1000000) 5836 (let ((best -1000000)
5648 (data gnus-newsgroup-data) 5837 (data gnus-newsgroup-data)
5649 article score) 5838 article score)
@@ -5668,21 +5857,27 @@ Return nil if there are no articles."
5668 (gnus-summary-goto-subject article)))) 5857 (gnus-summary-goto-subject article))))
5669 5858
5670(defun gnus-summary-goto-article (article &optional all-headers force) 5859(defun gnus-summary-goto-article (article &optional all-headers force)
5671 "Fetch ARTICLE and display it if it exists. 5860 "Fetch ARTICLE (article number or Message-ID) and display it if it exists.
5672If ALL-HEADERS is non-nil, no header lines are hidden." 5861If ALL-HEADERS is non-nil, no header lines are hidden.
5862If FORCE, go to the article even if it isn't displayed. If FORCE
5863is a number, it is the line the article is to be displayed on."
5673 (interactive 5864 (interactive
5674 (list 5865 (list
5675 (string-to-int 5866 (completing-read
5676 (completing-read 5867 "Article number or Message-ID: "
5677 "Article number: " 5868 (mapcar (lambda (number) (list (int-to-string number)))
5678 (mapcar (lambda (number) (list (int-to-string number))) 5869 gnus-newsgroup-limit))
5679 gnus-newsgroup-limit)))
5680 current-prefix-arg 5870 current-prefix-arg
5681 t)) 5871 t))
5682 (prog1 5872 (prog1
5683 (if (gnus-summary-goto-subject article force) 5873 (if (and (stringp article)
5684 (gnus-summary-display-article article all-headers) 5874 (string-match "@" article))
5685 (gnus-message 4 "Couldn't go to article %s" article) nil) 5875 (gnus-summary-refer-article article)
5876 (when (stringp article)
5877 (setq article (string-to-number article)))
5878 (if (gnus-summary-goto-subject article force)
5879 (gnus-summary-display-article article all-headers)
5880 (gnus-message 4 "Couldn't go to article %s" article) nil))
5686 (gnus-summary-position-point))) 5881 (gnus-summary-position-point)))
5687 5882
5688(defun gnus-summary-goto-last-article () 5883(defun gnus-summary-goto-last-article ()
@@ -5690,7 +5885,7 @@ If ALL-HEADERS is non-nil, no header lines are hidden."
5690 (interactive) 5885 (interactive)
5691 (prog1 5886 (prog1
5692 (when gnus-last-article 5887 (when gnus-last-article
5693 (gnus-summary-goto-article gnus-last-article)) 5888 (gnus-summary-goto-article gnus-last-article nil t))
5694 (gnus-summary-position-point))) 5889 (gnus-summary-position-point)))
5695 5890
5696(defun gnus-summary-pop-article (number) 5891(defun gnus-summary-pop-article (number)
@@ -5701,7 +5896,7 @@ NUMBER articles will be popped off."
5701 (setq gnus-newsgroup-history 5896 (setq gnus-newsgroup-history
5702 (cdr (setq to (nthcdr number gnus-newsgroup-history)))) 5897 (cdr (setq to (nthcdr number gnus-newsgroup-history))))
5703 (if to 5898 (if to
5704 (gnus-summary-goto-article (car to)) 5899 (gnus-summary-goto-article (car to) nil t)
5705 (error "Article history empty"))) 5900 (error "Article history empty")))
5706 (gnus-summary-position-point)) 5901 (gnus-summary-position-point))
5707 5902
@@ -5711,7 +5906,6 @@ NUMBER articles will be popped off."
5711 "Limit the summary buffer to the next N articles. 5906 "Limit the summary buffer to the next N articles.
5712If not given a prefix, use the process marked articles instead." 5907If not given a prefix, use the process marked articles instead."
5713 (interactive "P") 5908 (interactive "P")
5714 (gnus-set-global-variables)
5715 (prog1 5909 (prog1
5716 (let ((articles (gnus-summary-work-articles n))) 5910 (let ((articles (gnus-summary-work-articles n)))
5717 (setq gnus-newsgroup-processable nil) 5911 (setq gnus-newsgroup-processable nil)
@@ -5722,7 +5916,6 @@ If not given a prefix, use the process marked articles instead."
5722 "Restore the previous limit. 5916 "Restore the previous limit.
5723If given a prefix, remove all limits." 5917If given a prefix, remove all limits."
5724 (interactive "P") 5918 (interactive "P")
5725 (gnus-set-global-variables)
5726 (when total 5919 (when total
5727 (setq gnus-newsgroup-limits 5920 (setq gnus-newsgroup-limits
5728 (list (mapcar (lambda (h) (mail-header-number h)) 5921 (list (mapcar (lambda (h) (mail-header-number h))
@@ -5767,7 +5960,9 @@ articles that are younger than AGE days."
5767 (setq is-younger (nnmail-time-less 5960 (setq is-younger (nnmail-time-less
5768 (nnmail-time-since (nnmail-date-to-time date)) 5961 (nnmail-time-since (nnmail-date-to-time date))
5769 cutoff)) 5962 cutoff))
5770 (when (if younger-p is-younger (not is-younger)) 5963 (when (if younger-p
5964 is-younger
5965 (not is-younger))
5771 (push (gnus-data-number d) articles)))) 5966 (push (gnus-data-number d) articles))))
5772 (gnus-summary-limit (nreverse articles))) 5967 (gnus-summary-limit (nreverse articles)))
5773 (gnus-summary-position-point))) 5968 (gnus-summary-position-point)))
@@ -5810,8 +6005,7 @@ If REVERSE (the prefix), limit the summary buffer to articles that are
5810not marked with MARKS. MARKS can either be a string of marks or a 6005not marked with MARKS. MARKS can either be a string of marks or a
5811list of marks. 6006list of marks.
5812Returns how many articles were removed." 6007Returns how many articles were removed."
5813 (interactive (list (read-string "Marks: ") current-prefix-arg)) 6008 (interactive "sMarks: \nP")
5814 (gnus-set-global-variables)
5815 (prog1 6009 (prog1
5816 (let ((data gnus-newsgroup-data) 6010 (let ((data gnus-newsgroup-data)
5817 (marks (if (listp marks) marks 6011 (marks (if (listp marks) marks
@@ -5828,7 +6022,6 @@ Returns how many articles were removed."
5828(defun gnus-summary-limit-to-score (&optional score) 6022(defun gnus-summary-limit-to-score (&optional score)
5829 "Limit to articles with score at or above SCORE." 6023 "Limit to articles with score at or above SCORE."
5830 (interactive "P") 6024 (interactive "P")
5831 (gnus-set-global-variables)
5832 (setq score (if score 6025 (setq score (if score
5833 (prefix-numeric-value score) 6026 (prefix-numeric-value score)
5834 (or gnus-summary-default-score 0))) 6027 (or gnus-summary-default-score 0)))
@@ -5843,10 +6036,20 @@ Returns how many articles were removed."
5843 (gnus-summary-limit articles) 6036 (gnus-summary-limit articles)
5844 (gnus-summary-position-point)))) 6037 (gnus-summary-position-point))))
5845 6038
6039(defun gnus-summary-limit-include-thread (id)
6040 "Display all the hidden articles that in the current thread."
6041 (interactive (list (mail-header-id (gnus-summary-article-header))))
6042 (let ((articles (gnus-articles-in-thread
6043 (gnus-id-to-thread (gnus-root-id id)))))
6044 (prog1
6045 (gnus-summary-limit (nconc articles gnus-newsgroup-limit))
6046 (gnus-summary-position-point))))
6047
5846(defun gnus-summary-limit-include-dormant () 6048(defun gnus-summary-limit-include-dormant ()
5847 "Display all the hidden articles that are marked as dormant." 6049 "Display all the hidden articles that are marked as dormant.
6050Note that this command only works on a subset of the articles currently
6051fetched for this group."
5848 (interactive) 6052 (interactive)
5849 (gnus-set-global-variables)
5850 (unless gnus-newsgroup-dormant 6053 (unless gnus-newsgroup-dormant
5851 (error "There are no dormant articles in this group")) 6054 (error "There are no dormant articles in this group"))
5852 (prog1 6055 (prog1
@@ -5856,7 +6059,6 @@ Returns how many articles were removed."
5856(defun gnus-summary-limit-exclude-dormant () 6059(defun gnus-summary-limit-exclude-dormant ()
5857 "Hide all dormant articles." 6060 "Hide all dormant articles."
5858 (interactive) 6061 (interactive)
5859 (gnus-set-global-variables)
5860 (prog1 6062 (prog1
5861 (gnus-summary-limit-to-marks (list gnus-dormant-mark) 'reverse) 6063 (gnus-summary-limit-to-marks (list gnus-dormant-mark) 'reverse)
5862 (gnus-summary-position-point))) 6064 (gnus-summary-position-point)))
@@ -5864,7 +6066,6 @@ Returns how many articles were removed."
5864(defun gnus-summary-limit-exclude-childless-dormant () 6066(defun gnus-summary-limit-exclude-childless-dormant ()
5865 "Hide all dormant articles that have no children." 6067 "Hide all dormant articles that have no children."
5866 (interactive) 6068 (interactive)
5867 (gnus-set-global-variables)
5868 (let ((data (gnus-data-list t)) 6069 (let ((data (gnus-data-list t))
5869 articles d children) 6070 articles d children)
5870 ;; Find all articles that are either not dormant or have 6071 ;; Find all articles that are either not dormant or have
@@ -5897,7 +6098,8 @@ If ALL, mark even excluded ticked and dormants as read."
5897 '<) 6098 '<)
5898 (sort gnus-newsgroup-limit '<))) 6099 (sort gnus-newsgroup-limit '<)))
5899 article) 6100 article)
5900 (setq gnus-newsgroup-unreads gnus-newsgroup-limit) 6101 (setq gnus-newsgroup-unreads
6102 (gnus-intersection gnus-newsgroup-unreads gnus-newsgroup-limit))
5901 (if all 6103 (if all
5902 (setq gnus-newsgroup-dormant nil 6104 (setq gnus-newsgroup-dormant nil
5903 gnus-newsgroup-marked nil 6105 gnus-newsgroup-marked nil
@@ -5945,6 +6147,7 @@ If ALL, mark even excluded ticked and dormants as read."
5945 ;; after the current one. 6147 ;; after the current one.
5946 (goto-char (point-max)) 6148 (goto-char (point-max))
5947 (gnus-summary-find-prev)) 6149 (gnus-summary-find-prev))
6150 (gnus-set-mode-line 'summary)
5948 ;; We return how many articles were removed from the summary 6151 ;; We return how many articles were removed from the summary
5949 ;; buffer as a result of the new limit. 6152 ;; buffer as a result of the new limit.
5950 (- total (length gnus-newsgroup-data)))) 6153 (- total (length gnus-newsgroup-data))))
@@ -5960,6 +6163,7 @@ If ALL, mark even excluded ticked and dormants as read."
5960(defsubst gnus-cut-thread (thread) 6163(defsubst gnus-cut-thread (thread)
5961 "Go forwards in the thread until we find an article that we want to display." 6164 "Go forwards in the thread until we find an article that we want to display."
5962 (when (or (eq gnus-fetch-old-headers 'some) 6165 (when (or (eq gnus-fetch-old-headers 'some)
6166 (eq gnus-fetch-old-headers 'invisible)
5963 (eq gnus-build-sparse-threads 'some) 6167 (eq gnus-build-sparse-threads 'some)
5964 (eq gnus-build-sparse-threads 'more)) 6168 (eq gnus-build-sparse-threads 'more))
5965 ;; Deal with old-fetched headers and sparse threads. 6169 ;; Deal with old-fetched headers and sparse threads.
@@ -5969,25 +6173,26 @@ If ALL, mark even excluded ticked and dormants as read."
5969 (gnus-summary-article-sparse-p (mail-header-number (car thread))) 6173 (gnus-summary-article-sparse-p (mail-header-number (car thread)))
5970 (gnus-summary-article-ancient-p 6174 (gnus-summary-article-ancient-p
5971 (mail-header-number (car thread)))) 6175 (mail-header-number (car thread))))
5972 (progn 6176 (if (or (<= (length (cdr thread)) 1)
5973 (if (<= (length (cdr thread)) 1) 6177 (eq gnus-fetch-old-headers 'invisible))
5974 (setq gnus-newsgroup-limit 6178 (setq gnus-newsgroup-limit
5975 (delq (mail-header-number (car thread)) 6179 (delq (mail-header-number (car thread))
6180 gnus-newsgroup-limit)
6181 thread (cadr thread))
6182 (when (gnus-invisible-cut-children (cdr thread))
6183 (let ((th (cdr thread)))
6184 (while th
6185 (if (memq (mail-header-number (caar th))
5976 gnus-newsgroup-limit) 6186 gnus-newsgroup-limit)
5977 thread (cadr thread)) 6187 (setq thread (car th)
5978 (when (gnus-invisible-cut-children (cdr thread)) 6188 th nil)
5979 (let ((th (cdr thread))) 6189 (setq th (cdr th))))))))))
5980 (while th
5981 (if (memq (mail-header-number (caar th))
5982 gnus-newsgroup-limit)
5983 (setq thread (car th)
5984 th nil)
5985 (setq th (cdr th)))))))))))
5986 thread) 6190 thread)
5987 6191
5988(defun gnus-cut-threads (threads) 6192(defun gnus-cut-threads (threads)
5989 "Cut off all uninteresting articles from the beginning of threads." 6193 "Cut off all uninteresting articles from the beginning of threads."
5990 (when (or (eq gnus-fetch-old-headers 'some) 6194 (when (or (eq gnus-fetch-old-headers 'some)
6195 (eq gnus-fetch-old-headers 'invisible)
5991 (eq gnus-build-sparse-threads 'some) 6196 (eq gnus-build-sparse-threads 'some)
5992 (eq gnus-build-sparse-threads 'more)) 6197 (eq gnus-build-sparse-threads 'more))
5993 (let ((th threads)) 6198 (let ((th threads))
@@ -6005,6 +6210,7 @@ fetch-old-headers verbiage, and so on."
6005 (if (or gnus-inhibit-limiting 6210 (if (or gnus-inhibit-limiting
6006 (and (null gnus-newsgroup-dormant) 6211 (and (null gnus-newsgroup-dormant)
6007 (not (eq gnus-fetch-old-headers 'some)) 6212 (not (eq gnus-fetch-old-headers 'some))
6213 (not (eq gnus-fetch-old-headers 'invisible))
6008 (null gnus-summary-expunge-below) 6214 (null gnus-summary-expunge-below)
6009 (not (eq gnus-build-sparse-threads 'some)) 6215 (not (eq gnus-build-sparse-threads 'some))
6010 (not (eq gnus-build-sparse-threads 'more)) 6216 (not (eq gnus-build-sparse-threads 'more))
@@ -6060,6 +6266,10 @@ fetch-old-headers verbiage, and so on."
6060 (and (eq gnus-fetch-old-headers 'some) 6266 (and (eq gnus-fetch-old-headers 'some)
6061 (gnus-summary-article-ancient-p number) 6267 (gnus-summary-article-ancient-p number)
6062 (zerop children)) 6268 (zerop children))
6269 ;; If this is "fetch-old-headered" and `invisible', then
6270 ;; we don't want this article.
6271 (and (eq gnus-fetch-old-headers 'invisible)
6272 (gnus-summary-article-ancient-p number))
6063 ;; If this is a sparsely inserted article with no children, 6273 ;; If this is a sparsely inserted article with no children,
6064 ;; we don't want it. 6274 ;; we don't want it.
6065 (and (eq gnus-build-sparse-threads 'some) 6275 (and (eq gnus-build-sparse-threads 'some)
@@ -6121,7 +6331,6 @@ fetch-old-headers verbiage, and so on."
6121If N is negative, go to ancestor -N instead. 6331If N is negative, go to ancestor -N instead.
6122The difference between N and the number of articles fetched is returned." 6332The difference between N and the number of articles fetched is returned."
6123 (interactive "p") 6333 (interactive "p")
6124 (gnus-set-global-variables)
6125 (let ((skip 1) 6334 (let ((skip 1)
6126 error header ref) 6335 error header ref)
6127 (when (not (natnump n)) 6336 (when (not (natnump n))
@@ -6162,9 +6371,8 @@ The difference between N and the number of articles fetched is returned."
6162 6371
6163(defun gnus-summary-refer-references () 6372(defun gnus-summary-refer-references ()
6164 "Fetch all articles mentioned in the References header. 6373 "Fetch all articles mentioned in the References header.
6165Return how many articles were fetched." 6374Return the number of articles fetched."
6166 (interactive) 6375 (interactive)
6167 (gnus-set-global-variables)
6168 (let ((ref (mail-header-references (gnus-summary-article-header))) 6376 (let ((ref (mail-header-references (gnus-summary-article-header)))
6169 (current (gnus-summary-article-number)) 6377 (current (gnus-summary-article-number))
6170 (n 0)) 6378 (n 0))
@@ -6182,6 +6390,30 @@ Return how many articles were fetched."
6182 (gnus-summary-position-point) 6390 (gnus-summary-position-point)
6183 n))) 6391 n)))
6184 6392
6393(defun gnus-summary-refer-thread (&optional limit)
6394 "Fetch all articles in the current thread.
6395If LIMIT (the numerical prefix), fetch that many old headers instead
6396of what's specified by the `gnus-refer-thread-limit' variable."
6397 (interactive "P")
6398 (let ((id (mail-header-id (gnus-summary-article-header)))
6399 (limit (if limit (prefix-numeric-value limit)
6400 gnus-refer-thread-limit)))
6401 ;; We want to fetch LIMIT *old* headers, but we also have to
6402 ;; re-fetch all the headers in the current buffer, because many of
6403 ;; them may be undisplayed. So we adjust LIMIT.
6404 (when (numberp limit)
6405 (incf limit (- gnus-newsgroup-end gnus-newsgroup-begin)))
6406 (unless (eq gnus-fetch-old-headers 'invisible)
6407 (gnus-message 5 "Fetching headers for %s..." gnus-newsgroup-name)
6408 ;; Retrieve the headers and read them in.
6409 (if (eq (gnus-retrieve-headers
6410 (list gnus-newsgroup-end) gnus-newsgroup-name limit)
6411 'nov)
6412 (gnus-build-all-threads)
6413 (error "Can't fetch thread from backends that don't support NOV"))
6414 (gnus-message 5 "Fetching headers for %s...done" gnus-newsgroup-name))
6415 (gnus-summary-limit-include-thread id)))
6416
6185(defun gnus-summary-refer-article (message-id &optional arg) 6417(defun gnus-summary-refer-article (message-id &optional arg)
6186 "Fetch an article specified by MESSAGE-ID. 6418 "Fetch an article specified by MESSAGE-ID.
6187If ARG (the prefix), fetch the article using `gnus-refer-article-method' 6419If ARG (the prefix), fetch the article using `gnus-refer-article-method'
@@ -6201,16 +6433,18 @@ or `gnus-select-method', no matter what backend the article comes from."
6201 (mail-header-number header)) 6433 (mail-header-number header))
6202 (memq (mail-header-number header) 6434 (memq (mail-header-number header)
6203 gnus-newsgroup-limit)))) 6435 gnus-newsgroup-limit))))
6204 (if (and header 6436 (cond
6205 (or (not (gnus-summary-article-sparse-p 6437 ;; If the article is present in the buffer we just go to it.
6206 (mail-header-number header))) 6438 ((and header
6207 sparse)) 6439 (or (not (gnus-summary-article-sparse-p
6208 (prog1 6440 (mail-header-number header)))
6209 ;; The article is present in the buffer, so we just go to it. 6441 sparse))
6210 (gnus-summary-goto-article 6442 (prog1
6211 (mail-header-number header) nil t) 6443 (gnus-summary-goto-article
6212 (when sparse 6444 (mail-header-number header) nil t)
6213 (gnus-summary-update-article (mail-header-number header)))) 6445 (when sparse
6446 (gnus-summary-update-article (mail-header-number header)))))
6447 (t
6214 ;; We fetch the article 6448 ;; We fetch the article
6215 (let ((gnus-override-method 6449 (let ((gnus-override-method
6216 (cond ((gnus-news-group-p gnus-newsgroup-name) 6450 (cond ((gnus-news-group-p gnus-newsgroup-name)
@@ -6226,14 +6460,18 @@ or `gnus-select-method', no matter what backend the article comes from."
6226 ;; Fetch the header, and display the article. 6460 ;; Fetch the header, and display the article.
6227 (if (setq number (gnus-summary-insert-subject message-id)) 6461 (if (setq number (gnus-summary-insert-subject message-id))
6228 (gnus-summary-select-article nil nil nil number) 6462 (gnus-summary-select-article nil nil nil number)
6229 (gnus-message 3 "Couldn't fetch article %s" message-id))))))) 6463 (gnus-message 3 "Couldn't fetch article %s" message-id))))))))
6464
6465(defun gnus-summary-edit-parameters ()
6466 "Edit the group parameters of the current group."
6467 (interactive)
6468 (gnus-group-edit-group gnus-newsgroup-name 'params))
6230 6469
6231(defun gnus-summary-enter-digest-group (&optional force) 6470(defun gnus-summary-enter-digest-group (&optional force)
6232 "Enter an nndoc group based on the current article. 6471 "Enter an nndoc group based on the current article.
6233If FORCE, force a digest interpretation. If not, try 6472If FORCE, force a digest interpretation. If not, try
6234to guess what the document format is." 6473to guess what the document format is."
6235 (interactive "P") 6474 (interactive "P")
6236 (gnus-set-global-variables)
6237 (let ((conf gnus-current-window-configuration)) 6475 (let ((conf gnus-current-window-configuration))
6238 (save-excursion 6476 (save-excursion
6239 (gnus-summary-select-article)) 6477 (gnus-summary-select-article))
@@ -6331,12 +6569,12 @@ Obeys the standard process/prefix convention."
6331 "Do incremental search forward on the current article. 6569 "Do incremental search forward on the current article.
6332If REGEXP-P (the prefix) is non-nil, do regexp isearch." 6570If REGEXP-P (the prefix) is non-nil, do regexp isearch."
6333 (interactive "P") 6571 (interactive "P")
6334 (gnus-set-global-variables)
6335 (gnus-summary-select-article) 6572 (gnus-summary-select-article)
6336 (gnus-configure-windows 'article) 6573 (gnus-configure-windows 'article)
6337 (gnus-eval-in-buffer-window gnus-article-buffer 6574 (gnus-eval-in-buffer-window gnus-article-buffer
6338 ;;(goto-char (point-min)) 6575 (save-restriction
6339 (isearch-forward regexp-p))) 6576 (widen)
6577 (isearch-forward regexp-p))))
6340 6578
6341(defun gnus-summary-search-article-forward (regexp &optional backward) 6579(defun gnus-summary-search-article-forward (regexp &optional backward)
6342 "Search for an article containing REGEXP forward. 6580 "Search for an article containing REGEXP forward.
@@ -6349,7 +6587,6 @@ If BACKWARD, search backward instead."
6349 (concat ", default " gnus-last-search-regexp) 6587 (concat ", default " gnus-last-search-regexp)
6350 ""))) 6588 "")))
6351 current-prefix-arg)) 6589 current-prefix-arg))
6352 (gnus-set-global-variables)
6353 (if (string-equal regexp "") 6590 (if (string-equal regexp "")
6354 (setq regexp (or gnus-last-search-regexp "")) 6591 (setq regexp (or gnus-last-search-regexp ""))
6355 (setq gnus-last-search-regexp regexp)) 6592 (setq gnus-last-search-regexp regexp))
@@ -6471,7 +6708,6 @@ article. If BACKWARD (the prefix) is non-nil, search backward instead."
6471 current-prefix-arg)) 6708 current-prefix-arg))
6472 (when (equal header "Body") 6709 (when (equal header "Body")
6473 (setq header "")) 6710 (setq header ""))
6474 (gnus-set-global-variables)
6475 ;; Hidden thread subtrees must be searched as well. 6711 ;; Hidden thread subtrees must be searched as well.
6476 (gnus-summary-show-all-threads) 6712 (gnus-summary-show-all-threads)
6477 ;; We don't want to change current point nor window configuration. 6713 ;; We don't want to change current point nor window configuration.
@@ -6487,7 +6723,6 @@ article. If BACKWARD (the prefix) is non-nil, search backward instead."
6487(defun gnus-summary-beginning-of-article () 6723(defun gnus-summary-beginning-of-article ()
6488 "Scroll the article back to the beginning." 6724 "Scroll the article back to the beginning."
6489 (interactive) 6725 (interactive)
6490 (gnus-set-global-variables)
6491 (gnus-summary-select-article) 6726 (gnus-summary-select-article)
6492 (gnus-configure-windows 'article) 6727 (gnus-configure-windows 'article)
6493 (gnus-eval-in-buffer-window gnus-article-buffer 6728 (gnus-eval-in-buffer-window gnus-article-buffer
@@ -6499,7 +6734,6 @@ article. If BACKWARD (the prefix) is non-nil, search backward instead."
6499(defun gnus-summary-end-of-article () 6734(defun gnus-summary-end-of-article ()
6500 "Scroll to the end of the article." 6735 "Scroll to the end of the article."
6501 (interactive) 6736 (interactive)
6502 (gnus-set-global-variables)
6503 (gnus-summary-select-article) 6737 (gnus-summary-select-article)
6504 (gnus-configure-windows 'article) 6738 (gnus-configure-windows 'article)
6505 (gnus-eval-in-buffer-window gnus-article-buffer 6739 (gnus-eval-in-buffer-window gnus-article-buffer
@@ -6509,32 +6743,48 @@ article. If BACKWARD (the prefix) is non-nil, search backward instead."
6509 (when gnus-page-broken 6743 (when gnus-page-broken
6510 (gnus-narrow-to-page)))) 6744 (gnus-narrow-to-page))))
6511 6745
6512(defun gnus-summary-print-article (&optional filename) 6746(defun gnus-summary-print-article (&optional filename n)
6513 "Generate and print a PostScript image of the article buffer. 6747 "Generate and print a PostScript image of the N next (mail) articles.
6748
6749If N is negative, print the N previous articles. If N is nil and articles
6750have been marked with the process mark, print these instead.
6514 6751
6515If the optional argument FILENAME is nil, send the image to the printer. 6752If the optional second argument FILENAME is nil, send the image to the
6516If FILENAME is a string, save the PostScript image in a file with that 6753printer. If FILENAME is a string, save the PostScript image in a file with
6517name. If FILENAME is a number, prompt the user for the name of the file 6754that name. If FILENAME is a number, prompt the user for the name of the file
6518to save in." 6755to save in."
6519 (interactive (list (ps-print-preprint current-prefix-arg))) 6756 (interactive (list (ps-print-preprint current-prefix-arg)
6520 (gnus-summary-select-article) 6757 current-prefix-arg))
6521 (gnus-eval-in-buffer-window gnus-article-buffer 6758 (dolist (article (gnus-summary-work-articles n))
6522 (let ((buffer (generate-new-buffer " *print*"))) 6759 (gnus-summary-select-article nil nil 'pseudo article)
6523 (unwind-protect 6760 (gnus-eval-in-buffer-window gnus-article-buffer
6524 (progn 6761 (let ((buffer (generate-new-buffer " *print*")))
6525 (copy-to-buffer buffer (point-min) (point-max)) 6762 (unwind-protect
6526 (set-buffer buffer) 6763 (progn
6527 (gnus-article-delete-invisible-text) 6764 (copy-to-buffer buffer (point-min) (point-max))
6528 (run-hooks 'gnus-ps-print-hook) 6765 (set-buffer buffer)
6529 (ps-print-buffer-with-faces filename)) 6766 (gnus-article-delete-invisible-text)
6530 (kill-buffer buffer))))) 6767 (let ((ps-left-header
6768 (list
6769 (concat "("
6770 (mail-header-subject gnus-current-headers) ")")
6771 (concat "("
6772 (mail-header-from gnus-current-headers) ")")))
6773 (ps-right-header
6774 (list
6775 "/pagenumberstring load"
6776 (concat "("
6777 (mail-header-date gnus-current-headers) ")"))))
6778 (gnus-run-hooks 'gnus-ps-print-hook)
6779 (save-excursion
6780 (ps-print-buffer-with-faces filename))))
6781 (kill-buffer buffer))))))
6531 6782
6532(defun gnus-summary-show-article (&optional arg) 6783(defun gnus-summary-show-article (&optional arg)
6533 "Force re-fetching of the current article. 6784 "Force re-fetching of the current article.
6534If ARG (the prefix) is non-nil, show the raw article without any 6785If ARG (the prefix) is non-nil, show the raw article without any
6535article massaging functions being run." 6786article massaging functions being run."
6536 (interactive "P") 6787 (interactive "P")
6537 (gnus-set-global-variables)
6538 (if (not arg) 6788 (if (not arg)
6539 ;; Select the article the normal way. 6789 ;; Select the article the normal way.
6540 (gnus-summary-select-article nil 'force) 6790 (gnus-summary-select-article nil 'force)
@@ -6554,7 +6804,6 @@ article massaging functions being run."
6554If ARG is a positive number, turn header display on. 6804If ARG is a positive number, turn header display on.
6555If ARG is a negative number, turn header display off." 6805If ARG is a negative number, turn header display off."
6556 (interactive "P") 6806 (interactive "P")
6557 (gnus-set-global-variables)
6558 (setq gnus-show-all-headers 6807 (setq gnus-show-all-headers
6559 (cond ((or (not (numberp arg)) 6808 (cond ((or (not (numberp arg))
6560 (zerop arg)) 6809 (zerop arg))
@@ -6568,7 +6817,6 @@ If ARG is a negative number, turn header display off."
6568If ARG is a positive number, show the entire header. 6817If ARG is a positive number, show the entire header.
6569If ARG is a negative number, hide the unwanted header lines." 6818If ARG is a negative number, hide the unwanted header lines."
6570 (interactive "P") 6819 (interactive "P")
6571 (gnus-set-global-variables)
6572 (save-excursion 6820 (save-excursion
6573 (set-buffer gnus-article-buffer) 6821 (set-buffer gnus-article-buffer)
6574 (let* ((buffer-read-only nil) 6822 (let* ((buffer-read-only nil)
@@ -6587,21 +6835,19 @@ If ARG is a negative number, hide the unwanted header lines."
6587 (setq e (1- (or (search-forward "\n\n" nil t) (point-max))))) 6835 (setq e (1- (or (search-forward "\n\n" nil t) (point-max)))))
6588 (insert-buffer-substring gnus-original-article-buffer 1 e) 6836 (insert-buffer-substring gnus-original-article-buffer 1 e)
6589 (let ((article-inhibit-hiding t)) 6837 (let ((article-inhibit-hiding t))
6590 (run-hooks 'gnus-article-display-hook)) 6838 (gnus-run-hooks 'gnus-article-display-hook))
6591 (when (or (not hidden) (and (numberp arg) (< arg 0))) 6839 (when (or (not hidden) (and (numberp arg) (< arg 0)))
6592 (gnus-article-hide-headers))))) 6840 (gnus-article-hide-headers)))))
6593 6841
6594(defun gnus-summary-show-all-headers () 6842(defun gnus-summary-show-all-headers ()
6595 "Make all header lines visible." 6843 "Make all header lines visible."
6596 (interactive) 6844 (interactive)
6597 (gnus-set-global-variables)
6598 (gnus-article-show-all-headers)) 6845 (gnus-article-show-all-headers))
6599 6846
6600(defun gnus-summary-toggle-mime (&optional arg) 6847(defun gnus-summary-toggle-mime (&optional arg)
6601 "Toggle MIME processing. 6848 "Toggle MIME processing.
6602If ARG is a positive number, turn MIME processing on." 6849If ARG is a positive number, turn MIME processing on."
6603 (interactive "P") 6850 (interactive "P")
6604 (gnus-set-global-variables)
6605 (setq gnus-show-mime 6851 (setq gnus-show-mime
6606 (if (null arg) (not gnus-show-mime) 6852 (if (null arg) (not gnus-show-mime)
6607 (> (prefix-numeric-value arg) 0))) 6853 (> (prefix-numeric-value arg) 0)))
@@ -6612,7 +6858,6 @@ If ARG is a positive number, turn MIME processing on."
6612The numerical prefix specifies how many places to rotate each letter 6858The numerical prefix specifies how many places to rotate each letter
6613forward." 6859forward."
6614 (interactive "P") 6860 (interactive "P")
6615 (gnus-set-global-variables)
6616 (gnus-summary-select-article) 6861 (gnus-summary-select-article)
6617 (let ((mail-header-separator "")) 6862 (let ((mail-header-separator ""))
6618 (gnus-eval-in-buffer-window gnus-article-buffer 6863 (gnus-eval-in-buffer-window gnus-article-buffer
@@ -6626,14 +6871,14 @@ forward."
6626(defun gnus-summary-stop-page-breaking () 6871(defun gnus-summary-stop-page-breaking ()
6627 "Stop page breaking in the current article." 6872 "Stop page breaking in the current article."
6628 (interactive) 6873 (interactive)
6629 (gnus-set-global-variables)
6630 (gnus-summary-select-article) 6874 (gnus-summary-select-article)
6631 (gnus-eval-in-buffer-window gnus-article-buffer 6875 (gnus-eval-in-buffer-window gnus-article-buffer
6632 (widen) 6876 (widen)
6633 (when (gnus-visual-p 'page-marker) 6877 (when (gnus-visual-p 'page-marker)
6634 (let ((buffer-read-only nil)) 6878 (let ((buffer-read-only nil))
6635 (gnus-remove-text-with-property 'gnus-prev) 6879 (gnus-remove-text-with-property 'gnus-prev)
6636 (gnus-remove-text-with-property 'gnus-next))))) 6880 (gnus-remove-text-with-property 'gnus-next))
6881 (setq gnus-page-broken nil))))
6637 6882
6638(defun gnus-summary-move-article (&optional n to-newsgroup 6883(defun gnus-summary-move-article (&optional n to-newsgroup
6639 select-method action) 6884 select-method action)
@@ -6652,7 +6897,6 @@ and `request-accept' functions."
6652 (interactive "P") 6897 (interactive "P")
6653 (unless action 6898 (unless action
6654 (setq action 'move)) 6899 (setq action 'move))
6655 (gnus-set-global-variables)
6656 ;; Disable marking as read. 6900 ;; Disable marking as read.
6657 (let (gnus-mark-article-hook) 6901 (let (gnus-mark-article-hook)
6658 (save-window-excursion 6902 (save-window-excursion
@@ -6718,9 +6962,9 @@ and `request-accept' functions."
6718 ((eq action 'copy) 6962 ((eq action 'copy)
6719 (save-excursion 6963 (save-excursion
6720 (set-buffer copy-buf) 6964 (set-buffer copy-buf)
6721 (gnus-request-article-this-buffer article gnus-newsgroup-name) 6965 (when (gnus-request-article-this-buffer article gnus-newsgroup-name)
6722 (gnus-request-accept-article 6966 (gnus-request-accept-article
6723 to-newsgroup select-method (not articles)))) 6967 to-newsgroup select-method (not articles)))))
6724 ;; Crosspost the article. 6968 ;; Crosspost the article.
6725 ((eq action 'crosspost) 6969 ((eq action 'crosspost)
6726 (let ((xref (message-tokenize-header 6970 (let ((xref (message-tokenize-header
@@ -6760,15 +7004,10 @@ and `request-accept' functions."
6760 (gnus-summary-mark-article article gnus-canceled-mark) 7004 (gnus-summary-mark-article article gnus-canceled-mark)
6761 (gnus-message 4 "Deleted article %s" article)) 7005 (gnus-message 4 "Deleted article %s" article))
6762 (t 7006 (t
6763 (let* ((entry 7007 (let* ((pto-group (gnus-group-prefixed-name
6764 (or 7008 (car art-group) to-method))
6765 (gnus-gethash (car art-group) gnus-newsrc-hashtb) 7009 (entry
6766 (gnus-gethash 7010 (gnus-gethash pto-group gnus-newsrc-hashtb))
6767 (gnus-group-prefixed-name
6768 (car art-group)
6769 (or select-method
6770 (gnus-find-method-for-group to-newsgroup)))
6771 gnus-newsrc-hashtb)))
6772 (info (nth 2 entry)) 7011 (info (nth 2 entry))
6773 (to-group (gnus-info-group info))) 7012 (to-group (gnus-info-group info)))
6774 ;; Update the group that has been moved to. 7013 ;; Update the group that has been moved to.
@@ -6837,6 +7076,9 @@ and `request-accept' functions."
6837 (gnus-request-replace-article 7076 (gnus-request-replace-article
6838 article gnus-newsgroup-name (current-buffer))))) 7077 article gnus-newsgroup-name (current-buffer)))))
6839 7078
7079 ;;;!!!Why is this necessary?
7080 (set-buffer gnus-summary-buffer)
7081
6840 (gnus-summary-goto-subject article) 7082 (gnus-summary-goto-subject article)
6841 (when (eq action 'move) 7083 (when (eq action 'move)
6842 (gnus-summary-mark-article article gnus-canceled-mark)))) 7084 (gnus-summary-mark-article article gnus-canceled-mark))))
@@ -6909,7 +7151,6 @@ latter case, they will be copied into the relevant groups."
6909 (let ((ms-alist (mapcar (lambda (m) (cons (cadr m) m)) ms))) 7151 (let ((ms-alist (mapcar (lambda (m) (cons (cadr m) m)) ms)))
6910 (cdr (assoc (completing-read "Server name: " ms-alist nil t) 7152 (cdr (assoc (completing-read "Server name: " ms-alist nil t)
6911 ms-alist)))))))) 7153 ms-alist))))))))
6912 (gnus-set-global-variables)
6913 (unless method 7154 (unless method
6914 (error "No method given for respooling")) 7155 (error "No method given for respooling"))
6915 (if (assoc (symbol-name 7156 (if (assoc (symbol-name
@@ -6919,9 +7160,8 @@ latter case, they will be copied into the relevant groups."
6919 (gnus-summary-copy-article n nil method))) 7160 (gnus-summary-copy-article n nil method)))
6920 7161
6921(defun gnus-summary-import-article (file) 7162(defun gnus-summary-import-article (file)
6922 "Import a random file into a mail newsgroup." 7163 "Import an arbitrary file into a mail newsgroup."
6923 (interactive "fImport file: ") 7164 (interactive "fImport file: ")
6924 (gnus-set-global-variables)
6925 (let ((group gnus-newsgroup-name) 7165 (let ((group gnus-newsgroup-name)
6926 (now (current-time)) 7166 (now (current-time))
6927 atts lines) 7167 atts lines)
@@ -6931,7 +7171,7 @@ latter case, they will be copied into the relevant groups."
6931 (not (file-regular-p file)) 7171 (not (file-regular-p file))
6932 (error "Can't read %s" file)) 7172 (error "Can't read %s" file))
6933 (save-excursion 7173 (save-excursion
6934 (set-buffer (get-buffer-create " *import file*")) 7174 (set-buffer (gnus-get-buffer-create " *import file*"))
6935 (buffer-disable-undo (current-buffer)) 7175 (buffer-disable-undo (current-buffer))
6936 (erase-buffer) 7176 (erase-buffer)
6937 (insert-file-contents file) 7177 (insert-file-contents file)
@@ -6970,7 +7210,6 @@ This will be the case if the article has both been mailed and posted."
6970(defun gnus-summary-expire-articles (&optional now) 7210(defun gnus-summary-expire-articles (&optional now)
6971 "Expire all articles that are marked as expirable in the current group." 7211 "Expire all articles that are marked as expirable in the current group."
6972 (interactive) 7212 (interactive)
6973 (gnus-set-global-variables)
6974 (when (gnus-check-backend-function 7213 (when (gnus-check-backend-function
6975 'request-expire-articles gnus-newsgroup-name) 7214 'request-expire-articles gnus-newsgroup-name)
6976 ;; This backend supports expiry. 7215 ;; This backend supports expiry.
@@ -6980,7 +7219,7 @@ This will be the case if the article has both been mailed and posted."
6980 ;; We need to update the info for 7219 ;; We need to update the info for
6981 ;; this group for `gnus-list-of-read-articles' 7220 ;; this group for `gnus-list-of-read-articles'
6982 ;; to give us the right answer. 7221 ;; to give us the right answer.
6983 (run-hooks 'gnus-exit-group-hook) 7222 (gnus-run-hooks 'gnus-exit-group-hook)
6984 (gnus-summary-update-info) 7223 (gnus-summary-update-info)
6985 (gnus-list-of-read-articles gnus-newsgroup-name)) 7224 (gnus-list-of-read-articles gnus-newsgroup-name))
6986 (setq gnus-newsgroup-expirable 7225 (setq gnus-newsgroup-expirable
@@ -6994,13 +7233,14 @@ This will be the case if the article has both been mailed and posted."
6994 ;; through the expiry process. 7233 ;; through the expiry process.
6995 (gnus-message 6 "Expiring articles...") 7234 (gnus-message 6 "Expiring articles...")
6996 ;; The list of articles that weren't expired is returned. 7235 ;; The list of articles that weren't expired is returned.
6997 (if expiry-wait 7236 (save-excursion
6998 (let ((nnmail-expiry-wait-function nil) 7237 (if expiry-wait
6999 (nnmail-expiry-wait expiry-wait)) 7238 (let ((nnmail-expiry-wait-function nil)
7000 (setq es (gnus-request-expire-articles 7239 (nnmail-expiry-wait expiry-wait))
7001 expirable gnus-newsgroup-name))) 7240 (setq es (gnus-request-expire-articles
7002 (setq es (gnus-request-expire-articles 7241 expirable gnus-newsgroup-name)))
7003 expirable gnus-newsgroup-name))) 7242 (setq es (gnus-request-expire-articles
7243 expirable gnus-newsgroup-name))))
7004 (unless total 7244 (unless total
7005 (setq gnus-newsgroup-expirable es)) 7245 (setq gnus-newsgroup-expirable es))
7006 ;; We go through the old list of expirable, and mark all 7246 ;; We go through the old list of expirable, and mark all
@@ -7020,7 +7260,6 @@ This will be the case if the article has both been mailed and posted."
7020This means that *all* articles that are marked as expirable will be 7260This means that *all* articles that are marked as expirable will be
7021deleted forever, right now." 7261deleted forever, right now."
7022 (interactive) 7262 (interactive)
7023 (gnus-set-global-variables)
7024 (or gnus-expert-user 7263 (or gnus-expert-user
7025 (gnus-yes-or-no-p 7264 (gnus-yes-or-no-p
7026 "Are you really, really, really sure you want to delete all these messages? ") 7265 "Are you really, really, really sure you want to delete all these messages? ")
@@ -7037,12 +7276,11 @@ If N is negative, delete backwards.
7037If N is nil and articles have been marked with the process mark, 7276If N is nil and articles have been marked with the process mark,
7038delete these instead." 7277delete these instead."
7039 (interactive "P") 7278 (interactive "P")
7040 (gnus-set-global-variables)
7041 (unless (gnus-check-backend-function 'request-expire-articles 7279 (unless (gnus-check-backend-function 'request-expire-articles
7042 gnus-newsgroup-name) 7280 gnus-newsgroup-name)
7043 (error "The current newsgroup does not support article deletion")) 7281 (error "The current newsgroup does not support article deletion"))
7044 ;; Compute the list of articles to delete. 7282 ;; Compute the list of articles to delete.
7045 (let ((articles (gnus-summary-work-articles n)) 7283 (let ((articles (sort (copy-sequence (gnus-summary-work-articles n)) '<))
7046 not-deleted) 7284 not-deleted)
7047 (if (and gnus-novice-user 7285 (if (and gnus-novice-user
7048 (not (gnus-yes-or-no-p 7286 (not (gnus-yes-or-no-p
@@ -7085,67 +7323,73 @@ groups."
7085 (gnus-summary-select-article t)) 7323 (gnus-summary-select-article t))
7086 (gnus-article-date-original) 7324 (gnus-article-date-original)
7087 (gnus-article-edit-article 7325 (gnus-article-edit-article
7088 `(lambda () 7326 `(lambda (no-highlight)
7089 (gnus-summary-edit-article-done 7327 (gnus-summary-edit-article-done
7090 ,(or (mail-header-references gnus-current-headers) "") 7328 ,(or (mail-header-references gnus-current-headers) "")
7091 ,(gnus-group-read-only-p) ,gnus-summary-buffer))))) 7329 ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight)))))
7092 7330
7093(defalias 'gnus-summary-edit-article-postpone 'gnus-article-edit-exit) 7331(defalias 'gnus-summary-edit-article-postpone 'gnus-article-edit-exit)
7094 7332
7095(defun gnus-summary-edit-article-done (&optional references read-only buffer) 7333(defun gnus-summary-edit-article-done (&optional references read-only buffer
7334 no-highlight)
7096 "Make edits to the current article permanent." 7335 "Make edits to the current article permanent."
7097 (interactive) 7336 (interactive)
7098 ;; Replace the article. 7337 ;; Replace the article.
7099 (if (and (not read-only) 7338 (let ((buf (current-buffer)))
7100 (not (gnus-request-replace-article 7339 (nnheader-temp-write nil
7101 (cdr gnus-article-current) (car gnus-article-current) 7340 (insert-buffer buf)
7102 (current-buffer)))) 7341 (if (and (not read-only)
7103 (error "Couldn't replace article") 7342 (not (gnus-request-replace-article
7104 ;; Update the summary buffer. 7343 (cdr gnus-article-current) (car gnus-article-current)
7105 (if (and references 7344 (current-buffer))))
7106 (equal (message-tokenize-header references " ") 7345 (error "Couldn't replace article")
7107 (message-tokenize-header 7346 ;; Update the summary buffer.
7108 (or (message-fetch-field "references") "") " "))) 7347 (if (and references
7109 ;; We only have to update this line. 7348 (equal (message-tokenize-header references " ")
7110 (save-excursion 7349 (message-tokenize-header
7111 (save-restriction 7350 (or (message-fetch-field "references") "") " ")))
7112 (message-narrow-to-head) 7351 ;; We only have to update this line.
7113 (let ((head (buffer-string)) 7352 (save-excursion
7114 header) 7353 (save-restriction
7115 (nnheader-temp-write nil 7354 (message-narrow-to-head)
7116 (insert (format "211 %d Article retrieved.\n" 7355 (let ((head (buffer-string))
7117 (cdr gnus-article-current))) 7356 header)
7118 (insert head) 7357 (nnheader-temp-write nil
7119 (insert ".\n") 7358 (insert (format "211 %d Article retrieved.\n"
7120 (let ((nntp-server-buffer (current-buffer))) 7359 (cdr gnus-article-current)))
7121 (setq header (car (gnus-get-newsgroup-headers 7360 (insert head)
7122 (save-excursion 7361 (insert ".\n")
7123 (set-buffer gnus-summary-buffer) 7362 (let ((nntp-server-buffer (current-buffer)))
7124 gnus-newsgroup-dependencies) 7363 (setq header (car (gnus-get-newsgroup-headers
7125 t)))) 7364 (save-excursion
7126 (save-excursion 7365 (set-buffer gnus-summary-buffer)
7127 (set-buffer gnus-summary-buffer) 7366 gnus-newsgroup-dependencies)
7128 (gnus-data-set-header 7367 t))))
7129 (gnus-data-find (cdr gnus-article-current)) 7368 (save-excursion
7130 header) 7369 (set-buffer gnus-summary-buffer)
7131 (gnus-summary-update-article-line 7370 (gnus-data-set-header
7132 (cdr gnus-article-current) header)))))) 7371 (gnus-data-find (cdr gnus-article-current))
7133 ;; Update threads. 7372 header)
7134 (set-buffer (or buffer gnus-summary-buffer)) 7373 (gnus-summary-update-article-line
7135 (gnus-summary-update-article (cdr gnus-article-current))) 7374 (cdr gnus-article-current) header))))))
7136 ;; Prettify the article buffer again. 7375 ;; Update threads.
7137 (save-excursion 7376 (set-buffer (or buffer gnus-summary-buffer))
7138 (set-buffer gnus-article-buffer) 7377 (gnus-summary-update-article (cdr gnus-article-current)))
7139 (run-hooks 'gnus-article-display-hook) 7378 ;; Prettify the article buffer again.
7140 (set-buffer gnus-original-article-buffer) 7379 (unless no-highlight
7141 (gnus-request-article 7380 (save-excursion
7142 (cdr gnus-article-current) (car gnus-article-current) (current-buffer))) 7381 (set-buffer gnus-article-buffer)
7143 ;; Prettify the summary buffer line. 7382 (gnus-run-hooks 'gnus-article-display-hook)
7144 (when (gnus-visual-p 'summary-highlight 'highlight) 7383 (set-buffer gnus-original-article-buffer)
7145 (run-hooks 'gnus-visual-mark-article-hook)))) 7384 (gnus-request-article
7385 (cdr gnus-article-current)
7386 (car gnus-article-current) (current-buffer))))
7387 ;; Prettify the summary buffer line.
7388 (when (gnus-visual-p 'summary-highlight 'highlight)
7389 (gnus-run-hooks 'gnus-visual-mark-article-hook))))))
7146 7390
7147(defun gnus-summary-edit-wash (key) 7391(defun gnus-summary-edit-wash (key)
7148 "Perform editing command in the article buffer." 7392 "Perform editing command KEY in the article buffer."
7149 (interactive 7393 (interactive
7150 (list 7394 (list
7151 (progn 7395 (progn
@@ -7158,17 +7402,16 @@ groups."
7158 7402
7159;;; Respooling 7403;;; Respooling
7160 7404
7161(defun gnus-summary-respool-query (&optional silent) 7405(defun gnus-summary-respool-query (&optional silent trace)
7162 "Query where the respool algorithm would put this article." 7406 "Query where the respool algorithm would put this article."
7163 (interactive) 7407 (interactive)
7164 (gnus-set-global-variables)
7165 (let (gnus-mark-article-hook) 7408 (let (gnus-mark-article-hook)
7166 (gnus-summary-select-article) 7409 (gnus-summary-select-article)
7167 (save-excursion 7410 (save-excursion
7168 (set-buffer gnus-original-article-buffer) 7411 (set-buffer gnus-original-article-buffer)
7169 (save-restriction 7412 (save-restriction
7170 (message-narrow-to-head) 7413 (message-narrow-to-head)
7171 (let ((groups (nnmail-article-group 'identity))) 7414 (let ((groups (nnmail-article-group 'identity trace)))
7172 (unless silent 7415 (unless silent
7173 (if groups 7416 (if groups
7174 (message "This message would go to %s" 7417 (message "This message would go to %s"
@@ -7176,6 +7419,12 @@ groups."
7176 (message "This message would go to no groups")) 7419 (message "This message would go to no groups"))
7177 groups)))))) 7420 groups))))))
7178 7421
7422(defun gnus-summary-respool-trace ()
7423 "Trace where the respool algorithm would put this article.
7424Display a buffer showing all fancy splitting patterns which matched."
7425 (interactive)
7426 (gnus-summary-respool-query nil t))
7427
7179;; Summary marking commands. 7428;; Summary marking commands.
7180 7429
7181(defun gnus-summary-kill-same-subject-and-select (&optional unmark) 7430(defun gnus-summary-kill-same-subject-and-select (&optional unmark)
@@ -7183,7 +7432,6 @@ groups."
7183If UNMARK is positive, remove any kind of mark. 7432If UNMARK is positive, remove any kind of mark.
7184If UNMARK is negative, tick articles." 7433If UNMARK is negative, tick articles."
7185 (interactive "P") 7434 (interactive "P")
7186 (gnus-set-global-variables)
7187 (when unmark 7435 (when unmark
7188 (setq unmark (prefix-numeric-value unmark))) 7436 (setq unmark (prefix-numeric-value unmark)))
7189 (let ((count 7437 (let ((count
@@ -7202,7 +7450,6 @@ If UNMARK is negative, tick articles."
7202If UNMARK is positive, remove any kind of mark. 7450If UNMARK is positive, remove any kind of mark.
7203If UNMARK is negative, tick articles." 7451If UNMARK is negative, tick articles."
7204 (interactive "P") 7452 (interactive "P")
7205 (gnus-set-global-variables)
7206 (when unmark 7453 (when unmark
7207 (setq unmark (prefix-numeric-value unmark))) 7454 (setq unmark (prefix-numeric-value unmark)))
7208 (let ((count 7455 (let ((count
@@ -7253,7 +7500,6 @@ If N is negative, mark backward instead. If UNMARK is non-nil, remove
7253the process mark instead. The difference between N and the actual 7500the process mark instead. The difference between N and the actual
7254number of articles marked is returned." 7501number of articles marked is returned."
7255 (interactive "p") 7502 (interactive "p")
7256 (gnus-set-global-variables)
7257 (let ((backward (< n 0)) 7503 (let ((backward (< n 0))
7258 (n (abs n))) 7504 (n (abs n)))
7259 (while (and 7505 (while (and
@@ -7272,16 +7518,14 @@ number of articles marked is returned."
7272 7518
7273(defun gnus-summary-unmark-as-processable (n) 7519(defun gnus-summary-unmark-as-processable (n)
7274 "Remove the process mark from the next N articles. 7520 "Remove the process mark from the next N articles.
7275If N is negative, mark backward instead. The difference between N and 7521If N is negative, unmark backward instead. The difference between N and
7276the actual number of articles marked is returned." 7522the actual number of articles unmarked is returned."
7277 (interactive "p") 7523 (interactive "p")
7278 (gnus-set-global-variables)
7279 (gnus-summary-mark-as-processable n t)) 7524 (gnus-summary-mark-as-processable n t))
7280 7525
7281(defun gnus-summary-unmark-all-processable () 7526(defun gnus-summary-unmark-all-processable ()
7282 "Remove the process mark from all articles." 7527 "Remove the process mark from all articles."
7283 (interactive) 7528 (interactive)
7284 (gnus-set-global-variables)
7285 (save-excursion 7529 (save-excursion
7286 (while gnus-newsgroup-processable 7530 (while gnus-newsgroup-processable
7287 (gnus-summary-remove-process-mark (car gnus-newsgroup-processable)))) 7531 (gnus-summary-remove-process-mark (car gnus-newsgroup-processable))))
@@ -7292,7 +7536,6 @@ the actual number of articles marked is returned."
7292If N is negative, mark backward instead. The difference between N and 7536If N is negative, mark backward instead. The difference between N and
7293the actual number of articles marked is returned." 7537the actual number of articles marked is returned."
7294 (interactive "p") 7538 (interactive "p")
7295 (gnus-set-global-variables)
7296 (gnus-summary-mark-forward n gnus-expirable-mark)) 7539 (gnus-summary-mark-forward n gnus-expirable-mark))
7297 7540
7298(defun gnus-summary-mark-article-as-replied (article) 7541(defun gnus-summary-mark-article-as-replied (article)
@@ -7305,7 +7548,6 @@ the actual number of articles marked is returned."
7305(defun gnus-summary-set-bookmark (article) 7548(defun gnus-summary-set-bookmark (article)
7306 "Set a bookmark in current article." 7549 "Set a bookmark in current article."
7307 (interactive (list (gnus-summary-article-number))) 7550 (interactive (list (gnus-summary-article-number)))
7308 (gnus-set-global-variables)
7309 (when (or (not (get-buffer gnus-article-buffer)) 7551 (when (or (not (get-buffer gnus-article-buffer))
7310 (not gnus-current-article) 7552 (not gnus-current-article)
7311 (not gnus-article-current) 7553 (not gnus-article-current)
@@ -7335,7 +7577,6 @@ the actual number of articles marked is returned."
7335(defun gnus-summary-remove-bookmark (article) 7577(defun gnus-summary-remove-bookmark (article)
7336 "Remove the bookmark from the current article." 7578 "Remove the bookmark from the current article."
7337 (interactive (list (gnus-summary-article-number))) 7579 (interactive (list (gnus-summary-article-number)))
7338 (gnus-set-global-variables)
7339 ;; Remove old bookmark, if one exists. 7580 ;; Remove old bookmark, if one exists.
7340 (let ((old (assq article gnus-newsgroup-bookmarks))) 7581 (let ((old (assq article gnus-newsgroup-bookmarks)))
7341 (if old 7582 (if old
@@ -7351,7 +7592,6 @@ the actual number of articles marked is returned."
7351If N is negative, mark backward instead. The difference between N and 7592If N is negative, mark backward instead. The difference between N and
7352the actual number of articles marked is returned." 7593the actual number of articles marked is returned."
7353 (interactive "p") 7594 (interactive "p")
7354 (gnus-set-global-variables)
7355 (gnus-summary-mark-forward n gnus-dormant-mark)) 7595 (gnus-summary-mark-forward n gnus-dormant-mark))
7356 7596
7357(defun gnus-summary-set-process-mark (article) 7597(defun gnus-summary-set-process-mark (article)
@@ -7361,6 +7601,7 @@ the actual number of articles marked is returned."
7361 (delq article gnus-newsgroup-processable))) 7601 (delq article gnus-newsgroup-processable)))
7362 (when (gnus-summary-goto-subject article) 7602 (when (gnus-summary-goto-subject article)
7363 (gnus-summary-show-thread) 7603 (gnus-summary-show-thread)
7604 (gnus-summary-goto-subject article)
7364 (gnus-summary-update-secondary-mark article))) 7605 (gnus-summary-update-secondary-mark article)))
7365 7606
7366(defun gnus-summary-remove-process-mark (article) 7607(defun gnus-summary-remove-process-mark (article)
@@ -7368,6 +7609,7 @@ the actual number of articles marked is returned."
7368 (setq gnus-newsgroup-processable (delq article gnus-newsgroup-processable)) 7609 (setq gnus-newsgroup-processable (delq article gnus-newsgroup-processable))
7369 (when (gnus-summary-goto-subject article) 7610 (when (gnus-summary-goto-subject article)
7370 (gnus-summary-show-thread) 7611 (gnus-summary-show-thread)
7612 (gnus-summary-goto-subject article)
7371 (gnus-summary-update-secondary-mark article))) 7613 (gnus-summary-update-secondary-mark article)))
7372 7614
7373(defun gnus-summary-set-saved-mark (article) 7615(defun gnus-summary-set-saved-mark (article)
@@ -7382,7 +7624,6 @@ If N is negative, mark backwards instead. Mark with MARK, ?r by default.
7382The difference between N and the actual number of articles marked is 7624The difference between N and the actual number of articles marked is
7383returned." 7625returned."
7384 (interactive "p") 7626 (interactive "p")
7385 (gnus-set-global-variables)
7386 (let ((backward (< n 0)) 7627 (let ((backward (< n 0))
7387 (gnus-summary-goto-unread 7628 (gnus-summary-goto-unread
7388 (and gnus-summary-goto-unread 7629 (and gnus-summary-goto-unread
@@ -7426,6 +7667,8 @@ returned."
7426 (= mark gnus-read-mark) (= mark gnus-souped-mark) 7667 (= mark gnus-read-mark) (= mark gnus-souped-mark)
7427 (= mark gnus-duplicate-mark))) 7668 (= mark gnus-duplicate-mark)))
7428 (setq mark gnus-expirable-mark) 7669 (setq mark gnus-expirable-mark)
7670 ;; Let the backend know about the mark change.
7671 (setq mark (gnus-request-update-mark gnus-newsgroup-name article mark))
7429 (push article gnus-newsgroup-expirable)) 7672 (push article gnus-newsgroup-expirable))
7430 ;; Set the mark in the buffer. 7673 ;; Set the mark in the buffer.
7431 (gnus-summary-update-mark mark 'unread) 7674 (gnus-summary-update-mark mark 'unread)
@@ -7433,36 +7676,41 @@ returned."
7433 7676
7434(defun gnus-summary-mark-article-as-unread (mark) 7677(defun gnus-summary-mark-article-as-unread (mark)
7435 "Mark the current article quickly as unread with MARK." 7678 "Mark the current article quickly as unread with MARK."
7436 (let ((article (gnus-summary-article-number))) 7679 (let* ((article (gnus-summary-article-number))
7437 (if (< article 0) 7680 (old-mark (gnus-summary-article-mark article)))
7438 (gnus-error 1 "Unmarkable article") 7681 ;; Allow the backend to change the mark.
7439 (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked)) 7682 (setq mark (gnus-request-update-mark gnus-newsgroup-name article mark))
7440 (setq gnus-newsgroup-dormant (delq article gnus-newsgroup-dormant)) 7683 (if (eq mark old-mark)
7441 (setq gnus-newsgroup-expirable (delq article gnus-newsgroup-expirable)) 7684 t
7442 (setq gnus-newsgroup-reads (delq article gnus-newsgroup-reads)) 7685 (if (<= article 0)
7443 (cond ((= mark gnus-ticked-mark) 7686 (progn
7444 (push article gnus-newsgroup-marked)) 7687 (gnus-error 1 "Can't mark negative article numbers")
7445 ((= mark gnus-dormant-mark) 7688 nil)
7446 (push article gnus-newsgroup-dormant)) 7689 (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked))
7447 (t 7690 (setq gnus-newsgroup-dormant (delq article gnus-newsgroup-dormant))
7448 (push article gnus-newsgroup-unreads))) 7691 (setq gnus-newsgroup-expirable (delq article gnus-newsgroup-expirable))
7449 (setq gnus-newsgroup-reads 7692 (setq gnus-newsgroup-reads (delq article gnus-newsgroup-reads))
7450 (delq (assq article gnus-newsgroup-reads) 7693 (cond ((= mark gnus-ticked-mark)
7451 gnus-newsgroup-reads)) 7694 (push article gnus-newsgroup-marked))
7695 ((= mark gnus-dormant-mark)
7696 (push article gnus-newsgroup-dormant))
7697 (t
7698 (push article gnus-newsgroup-unreads)))
7699 (gnus-pull article gnus-newsgroup-reads)
7452 7700
7453 ;; See whether the article is to be put in the cache. 7701 ;; See whether the article is to be put in the cache.
7454 (and gnus-use-cache 7702 (and gnus-use-cache
7455 (vectorp (gnus-summary-article-header article)) 7703 (vectorp (gnus-summary-article-header article))
7456 (save-excursion 7704 (save-excursion
7457 (gnus-cache-possibly-enter-article 7705 (gnus-cache-possibly-enter-article
7458 gnus-newsgroup-name article 7706 gnus-newsgroup-name article
7459 (gnus-summary-article-header article) 7707 (gnus-summary-article-header article)
7460 (= mark gnus-ticked-mark) 7708 (= mark gnus-ticked-mark)
7461 (= mark gnus-dormant-mark) (= mark gnus-unread-mark)))) 7709 (= mark gnus-dormant-mark) (= mark gnus-unread-mark))))
7462 7710
7463 ;; Fix the mark. 7711 ;; Fix the mark.
7464 (gnus-summary-update-mark mark 'unread)) 7712 (gnus-summary-update-mark mark 'unread)
7465 t)) 7713 t))))
7466 7714
7467(defun gnus-summary-mark-article (&optional article mark no-expire) 7715(defun gnus-summary-mark-article (&optional article mark no-expire)
7468 "Mark ARTICLE with MARK. MARK can be any character. 7716 "Mark ARTICLE with MARK. MARK can be any character.
@@ -7485,32 +7733,37 @@ marked."
7485 (= mark gnus-duplicate-mark)))) 7733 (= mark gnus-duplicate-mark))))
7486 (setq mark gnus-expirable-mark)) 7734 (setq mark gnus-expirable-mark))
7487 (let* ((mark (or mark gnus-del-mark)) 7735 (let* ((mark (or mark gnus-del-mark))
7488 (article (or article (gnus-summary-article-number)))) 7736 (article (or article (gnus-summary-article-number)))
7489 (unless article 7737 (old-mark (gnus-summary-article-mark article)))
7490 (error "No article on current line")) 7738 ;; Allow the backend to change the mark.
7491 (if (or (= mark gnus-unread-mark) 7739 (setq mark (gnus-request-update-mark gnus-newsgroup-name article mark))
7492 (= mark gnus-ticked-mark) 7740 (if (eq mark old-mark)
7493 (= mark gnus-dormant-mark)) 7741 t
7494 (gnus-mark-article-as-unread article mark) 7742 (unless article
7495 (gnus-mark-article-as-read article mark)) 7743 (error "No article on current line"))
7496 7744 (if (not (if (or (= mark gnus-unread-mark)
7497 ;; See whether the article is to be put in the cache. 7745 (= mark gnus-ticked-mark)
7498 (and gnus-use-cache 7746 (= mark gnus-dormant-mark))
7499 (not (= mark gnus-canceled-mark)) 7747 (gnus-mark-article-as-unread article mark)
7500 (vectorp (gnus-summary-article-header article)) 7748 (gnus-mark-article-as-read article mark)))
7501 (save-excursion 7749 t
7502 (gnus-cache-possibly-enter-article 7750 ;; See whether the article is to be put in the cache.
7503 gnus-newsgroup-name article 7751 (and gnus-use-cache
7504 (gnus-summary-article-header article) 7752 (not (= mark gnus-canceled-mark))
7505 (= mark gnus-ticked-mark) 7753 (vectorp (gnus-summary-article-header article))
7506 (= mark gnus-dormant-mark) (= mark gnus-unread-mark)))) 7754 (save-excursion
7507 7755 (gnus-cache-possibly-enter-article
7508 (when (gnus-summary-goto-subject article nil t) 7756 gnus-newsgroup-name article
7509 (let ((buffer-read-only nil)) 7757 (gnus-summary-article-header article)
7510 (gnus-summary-show-thread) 7758 (= mark gnus-ticked-mark)
7511 ;; Fix the mark. 7759 (= mark gnus-dormant-mark) (= mark gnus-unread-mark))))
7512 (gnus-summary-update-mark mark 'unread) 7760
7513 t)))) 7761 (when (gnus-summary-goto-subject article nil t)
7762 (let ((buffer-read-only nil))
7763 (gnus-summary-show-thread)
7764 ;; Fix the mark.
7765 (gnus-summary-update-mark mark 'unread)
7766 t))))))
7514 7767
7515(defun gnus-summary-update-secondary-mark (article) 7768(defun gnus-summary-update-secondary-mark (article)
7516 "Update the secondary (read, process, cache) mark." 7769 "Update the secondary (read, process, cache) mark."
@@ -7526,7 +7779,7 @@ marked."
7526 (t gnus-unread-mark)) 7779 (t gnus-unread-mark))
7527 'replied) 7780 'replied)
7528 (when (gnus-visual-p 'summary-highlight 'highlight) 7781 (when (gnus-visual-p 'summary-highlight 'highlight)
7529 (run-hooks 'gnus-summary-update-hook)) 7782 (gnus-run-hooks 'gnus-summary-update-hook))
7530 t) 7783 t)
7531 7784
7532(defun gnus-summary-update-mark (mark type) 7785(defun gnus-summary-update-mark (mark type)
@@ -7561,29 +7814,33 @@ marked."
7561 (push (cons article mark) gnus-newsgroup-reads) 7814 (push (cons article mark) gnus-newsgroup-reads)
7562 ;; Possibly remove from cache, if that is used. 7815 ;; Possibly remove from cache, if that is used.
7563 (when gnus-use-cache 7816 (when gnus-use-cache
7564 (gnus-cache-enter-remove-article article)))) 7817 (gnus-cache-enter-remove-article article))
7818 t))
7565 7819
7566(defun gnus-mark-article-as-unread (article &optional mark) 7820(defun gnus-mark-article-as-unread (article &optional mark)
7567 "Enter ARTICLE in the pertinent lists and remove it from others." 7821 "Enter ARTICLE in the pertinent lists and remove it from others."
7568 (let ((mark (or mark gnus-ticked-mark))) 7822 (let ((mark (or mark gnus-ticked-mark)))
7569 (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked) 7823 (if (<= article 0)
7570 gnus-newsgroup-dormant (delq article gnus-newsgroup-dormant) 7824 (progn
7571 gnus-newsgroup-expirable (delq article gnus-newsgroup-expirable) 7825 (gnus-error 1 "Can't mark negative article numbers")
7572 gnus-newsgroup-unreads (delq article gnus-newsgroup-unreads)) 7826 nil)
7827 (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked)
7828 gnus-newsgroup-dormant (delq article gnus-newsgroup-dormant)
7829 gnus-newsgroup-expirable (delq article gnus-newsgroup-expirable)
7830 gnus-newsgroup-unreads (delq article gnus-newsgroup-unreads))
7573 7831
7574 ;; Unsuppress duplicates? 7832 ;; Unsuppress duplicates?
7575 (when gnus-suppress-duplicates 7833 (when gnus-suppress-duplicates
7576 (gnus-dup-unsuppress-article article)) 7834 (gnus-dup-unsuppress-article article))
7577 7835
7578 (cond ((= mark gnus-ticked-mark) 7836 (cond ((= mark gnus-ticked-mark)
7579 (push article gnus-newsgroup-marked)) 7837 (push article gnus-newsgroup-marked))
7580 ((= mark gnus-dormant-mark) 7838 ((= mark gnus-dormant-mark)
7581 (push article gnus-newsgroup-dormant)) 7839 (push article gnus-newsgroup-dormant))
7582 (t 7840 (t
7583 (push article gnus-newsgroup-unreads))) 7841 (push article gnus-newsgroup-unreads)))
7584 (setq gnus-newsgroup-reads 7842 (gnus-pull article gnus-newsgroup-reads)
7585 (delq (assq article gnus-newsgroup-reads) 7843 t)))
7586 gnus-newsgroup-reads))))
7587 7844
7588(defalias 'gnus-summary-mark-as-unread-forward 7845(defalias 'gnus-summary-mark-as-unread-forward
7589 'gnus-summary-tick-article-forward) 7846 'gnus-summary-tick-article-forward)
@@ -7684,7 +7941,6 @@ even ticked and dormant ones."
7684(defun gnus-summary-mark-below (score mark) 7941(defun gnus-summary-mark-below (score mark)
7685 "Mark articles with score less than SCORE with MARK." 7942 "Mark articles with score less than SCORE with MARK."
7686 (interactive "P\ncMark: ") 7943 (interactive "P\ncMark: ")
7687 (gnus-set-global-variables)
7688 (setq score (if score 7944 (setq score (if score
7689 (prefix-numeric-value score) 7945 (prefix-numeric-value score)
7690 (or gnus-summary-default-score 0))) 7946 (or gnus-summary-default-score 0)))
@@ -7700,25 +7956,21 @@ even ticked and dormant ones."
7700(defun gnus-summary-kill-below (&optional score) 7956(defun gnus-summary-kill-below (&optional score)
7701 "Mark articles with score below SCORE as read." 7957 "Mark articles with score below SCORE as read."
7702 (interactive "P") 7958 (interactive "P")
7703 (gnus-set-global-variables)
7704 (gnus-summary-mark-below score gnus-killed-mark)) 7959 (gnus-summary-mark-below score gnus-killed-mark))
7705 7960
7706(defun gnus-summary-clear-above (&optional score) 7961(defun gnus-summary-clear-above (&optional score)
7707 "Clear all marks from articles with score above SCORE." 7962 "Clear all marks from articles with score above SCORE."
7708 (interactive "P") 7963 (interactive "P")
7709 (gnus-set-global-variables)
7710 (gnus-summary-mark-above score gnus-unread-mark)) 7964 (gnus-summary-mark-above score gnus-unread-mark))
7711 7965
7712(defun gnus-summary-tick-above (&optional score) 7966(defun gnus-summary-tick-above (&optional score)
7713 "Tick all articles with score above SCORE." 7967 "Tick all articles with score above SCORE."
7714 (interactive "P") 7968 (interactive "P")
7715 (gnus-set-global-variables)
7716 (gnus-summary-mark-above score gnus-ticked-mark)) 7969 (gnus-summary-mark-above score gnus-ticked-mark))
7717 7970
7718(defun gnus-summary-mark-above (score mark) 7971(defun gnus-summary-mark-above (score mark)
7719 "Mark articles with score over SCORE with MARK." 7972 "Mark articles with score over SCORE with MARK."
7720 (interactive "P\ncMark: ") 7973 (interactive "P\ncMark: ")
7721 (gnus-set-global-variables)
7722 (setq score (if score 7974 (setq score (if score
7723 (prefix-numeric-value score) 7975 (prefix-numeric-value score)
7724 (or gnus-summary-default-score 0))) 7976 (or gnus-summary-default-score 0)))
@@ -7736,7 +7988,6 @@ even ticked and dormant ones."
7736(defun gnus-summary-limit-include-expunged (&optional no-error) 7988(defun gnus-summary-limit-include-expunged (&optional no-error)
7737 "Display all the hidden articles that were expunged for low scores." 7989 "Display all the hidden articles that were expunged for low scores."
7738 (interactive) 7990 (interactive)
7739 (gnus-set-global-variables)
7740 (let ((buffer-read-only nil)) 7991 (let ((buffer-read-only nil))
7741 (let ((scored gnus-newsgroup-scored) 7992 (let ((scored gnus-newsgroup-scored)
7742 headers h) 7993 headers h)
@@ -7766,7 +8017,6 @@ Note that this function will only catch up the unread article
7766in the current summary buffer limitation. 8017in the current summary buffer limitation.
7767The number of articles marked as read is returned." 8018The number of articles marked as read is returned."
7768 (interactive "P") 8019 (interactive "P")
7769 (gnus-set-global-variables)
7770 (prog1 8020 (prog1
7771 (save-excursion 8021 (save-excursion
7772 (when (or quietly 8022 (when (or quietly
@@ -7781,20 +8031,20 @@ The number of articles marked as read is returned."
7781 (not gnus-newsgroup-auto-expire) 8031 (not gnus-newsgroup-auto-expire)
7782 (not gnus-suppress-duplicates) 8032 (not gnus-suppress-duplicates)
7783 (or (not gnus-use-cache) 8033 (or (not gnus-use-cache)
7784 (not (eq gnus-use-cache 'passive)))) 8034 (eq gnus-use-cache 'passive)))
7785 (progn 8035 (progn
7786 (when all 8036 (when all
7787 (setq gnus-newsgroup-marked nil 8037 (setq gnus-newsgroup-marked nil
7788 gnus-newsgroup-dormant nil)) 8038 gnus-newsgroup-dormant nil))
7789 (setq gnus-newsgroup-unreads nil)) 8039 (setq gnus-newsgroup-unreads gnus-newsgroup-downloadable))
7790 ;; We actually mark all articles as canceled, which we 8040 ;; We actually mark all articles as canceled, which we
7791 ;; have to do when using auto-expiry or adaptive scoring. 8041 ;; have to do when using auto-expiry or adaptive scoring.
7792 (gnus-summary-show-all-threads) 8042 (gnus-summary-show-all-threads)
7793 (when (gnus-summary-first-subject (not all)) 8043 (when (gnus-summary-first-subject (not all) t)
7794 (while (and 8044 (while (and
7795 (if to-here (< (point) to-here) t) 8045 (if to-here (< (point) to-here) t)
7796 (gnus-summary-mark-article-as-read gnus-catchup-mark) 8046 (gnus-summary-mark-article-as-read gnus-catchup-mark)
7797 (gnus-summary-find-next (not all))))) 8047 (gnus-summary-find-next (not all) nil nil t))))
7798 (gnus-set-mode-line 'summary)) 8048 (gnus-set-mode-line 'summary))
7799 t)) 8049 t))
7800 (gnus-summary-position-point))) 8050 (gnus-summary-position-point)))
@@ -7803,7 +8053,6 @@ The number of articles marked as read is returned."
7803 "Mark all unticked articles before the current one as read. 8053 "Mark all unticked articles before the current one as read.
7804If ALL is non-nil, also mark ticked and dormant articles as read." 8054If ALL is non-nil, also mark ticked and dormant articles as read."
7805 (interactive "P") 8055 (interactive "P")
7806 (gnus-set-global-variables)
7807 (save-excursion 8056 (save-excursion
7808 (gnus-save-hidden-threads 8057 (gnus-save-hidden-threads
7809 (let ((beg (point))) 8058 (let ((beg (point)))
@@ -7815,24 +8064,22 @@ If ALL is non-nil, also mark ticked and dormant articles as read."
7815(defun gnus-summary-catchup-all (&optional quietly) 8064(defun gnus-summary-catchup-all (&optional quietly)
7816 "Mark all articles in this newsgroup as read." 8065 "Mark all articles in this newsgroup as read."
7817 (interactive "P") 8066 (interactive "P")
7818 (gnus-set-global-variables)
7819 (gnus-summary-catchup t quietly)) 8067 (gnus-summary-catchup t quietly))
7820 8068
7821(defun gnus-summary-catchup-and-exit (&optional all quietly) 8069(defun gnus-summary-catchup-and-exit (&optional all quietly)
7822 "Mark all articles not marked as unread in this newsgroup as read, then exit. 8070 "Mark all articles not marked as unread in this newsgroup as read, then exit.
7823If prefix argument ALL is non-nil, all articles are marked as read." 8071If prefix argument ALL is non-nil, all articles are marked as read."
7824 (interactive "P") 8072 (interactive "P")
7825 (gnus-set-global-variables)
7826 (when (gnus-summary-catchup all quietly nil 'fast) 8073 (when (gnus-summary-catchup all quietly nil 'fast)
7827 ;; Select next newsgroup or exit. 8074 ;; Select next newsgroup or exit.
7828 (if (eq gnus-auto-select-next 'quietly) 8075 (if (and (not (gnus-group-quit-config gnus-newsgroup-name))
8076 (eq gnus-auto-select-next 'quietly))
7829 (gnus-summary-next-group nil) 8077 (gnus-summary-next-group nil)
7830 (gnus-summary-exit)))) 8078 (gnus-summary-exit))))
7831 8079
7832(defun gnus-summary-catchup-all-and-exit (&optional quietly) 8080(defun gnus-summary-catchup-all-and-exit (&optional quietly)
7833 "Mark all articles in this newsgroup as read, and then exit." 8081 "Mark all articles in this newsgroup as read, and then exit."
7834 (interactive "P") 8082 (interactive "P")
7835 (gnus-set-global-variables)
7836 (gnus-summary-catchup-and-exit t quietly)) 8083 (gnus-summary-catchup-and-exit t quietly))
7837 8084
7838;; Suggested by "Arne Eofsson" <arne@hodgkin.mbi.ucla.edu>. 8085;; Suggested by "Arne Eofsson" <arne@hodgkin.mbi.ucla.edu>.
@@ -7841,7 +8088,6 @@ If prefix argument ALL is non-nil, all articles are marked as read."
7841If given a prefix, mark all articles, unread as well as ticked, as 8088If given a prefix, mark all articles, unread as well as ticked, as
7842read." 8089read."
7843 (interactive "P") 8090 (interactive "P")
7844 (gnus-set-global-variables)
7845 (save-excursion 8091 (save-excursion
7846 (gnus-summary-catchup all)) 8092 (gnus-summary-catchup all))
7847 (gnus-summary-next-article t nil nil t)) 8093 (gnus-summary-next-article t nil nil t))
@@ -7888,7 +8134,6 @@ with that article."
7888(defun gnus-summary-rethread-current () 8134(defun gnus-summary-rethread-current ()
7889 "Rethread the thread the current article is part of." 8135 "Rethread the thread the current article is part of."
7890 (interactive) 8136 (interactive)
7891 (gnus-set-global-variables)
7892 (let* ((gnus-show-threads t) 8137 (let* ((gnus-show-threads t)
7893 (article (gnus-summary-article-number)) 8138 (article (gnus-summary-article-number))
7894 (id (mail-header-id (gnus-summary-article-header))) 8139 (id (mail-header-id (gnus-summary-article-header)))
@@ -7924,14 +8169,20 @@ is non-nil or the Subject: of both articles are the same."
7924 (gnus-summary-article-header parent-article)))) 8169 (gnus-summary-article-header parent-article))))
7925 (unless (and message-id (not (equal message-id ""))) 8170 (unless (and message-id (not (equal message-id "")))
7926 (error "No message-id in desired parent")) 8171 (error "No message-id in desired parent"))
7927 (gnus-summary-select-article t t nil current-article) 8172 ;; We don't want the article to be marked as read.
8173 (let (gnus-mark-article-hook)
8174 (gnus-summary-select-article t t nil current-article))
7928 (set-buffer gnus-original-article-buffer) 8175 (set-buffer gnus-original-article-buffer)
7929 (let ((buf (format "%s" (buffer-string)))) 8176 (let ((buf (format "%s" (buffer-string))))
7930 (nnheader-temp-write nil 8177 (nnheader-temp-write nil
7931 (insert buf) 8178 (insert buf)
7932 (goto-char (point-min)) 8179 (goto-char (point-min))
7933 (if (search-forward-regexp "^References: " nil t) 8180 (if (re-search-forward "^References: " nil t)
7934 (insert message-id " " ) 8181 (progn
8182 (re-search-forward "^[^ \t]" nil t)
8183 (forward-line -1)
8184 (end-of-line)
8185 (insert " " message-id))
7935 (insert "References: " message-id "\n")) 8186 (insert "References: " message-id "\n"))
7936 (unless (gnus-request-replace-article 8187 (unless (gnus-request-replace-article
7937 current-article (car gnus-article-current) 8188 current-article (car gnus-article-current)
@@ -7939,6 +8190,7 @@ is non-nil or the Subject: of both articles are the same."
7939 (error "Couldn't replace article")))) 8190 (error "Couldn't replace article"))))
7940 (set-buffer gnus-summary-buffer) 8191 (set-buffer gnus-summary-buffer)
7941 (gnus-summary-unmark-all-processable) 8192 (gnus-summary-unmark-all-processable)
8193 (gnus-summary-update-article current-article)
7942 (gnus-summary-rethread-current) 8194 (gnus-summary-rethread-current)
7943 (gnus-message 3 "Article %d is now the child of article %d" 8195 (gnus-message 3 "Article %d is now the child of article %d"
7944 current-article parent-article))))) 8196 current-article parent-article)))))
@@ -7947,7 +8199,6 @@ is non-nil or the Subject: of both articles are the same."
7947 "Toggle showing conversation threads. 8199 "Toggle showing conversation threads.
7948If ARG is positive number, turn showing conversation threads on." 8200If ARG is positive number, turn showing conversation threads on."
7949 (interactive "P") 8201 (interactive "P")
7950 (gnus-set-global-variables)
7951 (let ((current (or (gnus-summary-article-number) gnus-newsgroup-end))) 8202 (let ((current (or (gnus-summary-article-number) gnus-newsgroup-end)))
7952 (setq gnus-show-threads 8203 (setq gnus-show-threads
7953 (if (null arg) (not gnus-show-threads) 8204 (if (null arg) (not gnus-show-threads)
@@ -7960,7 +8211,6 @@ If ARG is positive number, turn showing conversation threads on."
7960(defun gnus-summary-show-all-threads () 8211(defun gnus-summary-show-all-threads ()
7961 "Show all threads." 8212 "Show all threads."
7962 (interactive) 8213 (interactive)
7963 (gnus-set-global-variables)
7964 (save-excursion 8214 (save-excursion
7965 (let ((buffer-read-only nil)) 8215 (let ((buffer-read-only nil))
7966 (subst-char-in-region (point-min) (point-max) ?\^M ?\n t))) 8216 (subst-char-in-region (point-min) (point-max) ?\^M ?\n t)))
@@ -7970,7 +8220,6 @@ If ARG is positive number, turn showing conversation threads on."
7970 "Show thread subtrees. 8220 "Show thread subtrees.
7971Returns nil if no thread was there to be shown." 8221Returns nil if no thread was there to be shown."
7972 (interactive) 8222 (interactive)
7973 (gnus-set-global-variables)
7974 (let ((buffer-read-only nil) 8223 (let ((buffer-read-only nil)
7975 (orig (point)) 8224 (orig (point))
7976 ;; first goto end then to beg, to have point at beg after let 8225 ;; first goto end then to beg, to have point at beg after let
@@ -7986,7 +8235,6 @@ Returns nil if no thread was there to be shown."
7986(defun gnus-summary-hide-all-threads () 8235(defun gnus-summary-hide-all-threads ()
7987 "Hide all thread subtrees." 8236 "Hide all thread subtrees."
7988 (interactive) 8237 (interactive)
7989 (gnus-set-global-variables)
7990 (save-excursion 8238 (save-excursion
7991 (goto-char (point-min)) 8239 (goto-char (point-min))
7992 (gnus-summary-hide-thread) 8240 (gnus-summary-hide-thread)
@@ -7998,7 +8246,6 @@ Returns nil if no thread was there to be shown."
7998 "Hide thread subtrees. 8246 "Hide thread subtrees.
7999Returns nil if no threads were there to be hidden." 8247Returns nil if no threads were there to be hidden."
8000 (interactive) 8248 (interactive)
8001 (gnus-set-global-variables)
8002 (let ((buffer-read-only nil) 8249 (let ((buffer-read-only nil)
8003 (start (point)) 8250 (start (point))
8004 (article (gnus-summary-article-number))) 8251 (article (gnus-summary-article-number)))
@@ -8047,7 +8294,6 @@ done.
8047 8294
8048If SILENT, don't output messages." 8295If SILENT, don't output messages."
8049 (interactive "p") 8296 (interactive "p")
8050 (gnus-set-global-variables)
8051 (let ((backward (< n 0)) 8297 (let ((backward (< n 0))
8052 (n (abs n))) 8298 (n (abs n)))
8053 (while (and (> n 0) 8299 (while (and (> n 0)
@@ -8064,7 +8310,6 @@ If SILENT, don't output messages."
8064Returns the difference between N and the number of skips actually 8310Returns the difference between N and the number of skips actually
8065done." 8311done."
8066 (interactive "p") 8312 (interactive "p")
8067 (gnus-set-global-variables)
8068 (gnus-summary-next-thread (- n))) 8313 (gnus-summary-next-thread (- n)))
8069 8314
8070(defun gnus-summary-go-down-thread () 8315(defun gnus-summary-go-down-thread ()
@@ -8085,7 +8330,6 @@ If N is negative, go up instead.
8085Returns the difference between N and how many steps down that were 8330Returns the difference between N and how many steps down that were
8086taken." 8331taken."
8087 (interactive "p") 8332 (interactive "p")
8088 (gnus-set-global-variables)
8089 (let ((up (< n 0)) 8333 (let ((up (< n 0))
8090 (n (abs n))) 8334 (n (abs n)))
8091 (while (and (> n 0) 8335 (while (and (> n 0)
@@ -8103,13 +8347,11 @@ If N is negative, go up instead.
8103Returns the difference between N and how many steps down that were 8347Returns the difference between N and how many steps down that were
8104taken." 8348taken."
8105 (interactive "p") 8349 (interactive "p")
8106 (gnus-set-global-variables)
8107 (gnus-summary-down-thread (- n))) 8350 (gnus-summary-down-thread (- n)))
8108 8351
8109(defun gnus-summary-top-thread () 8352(defun gnus-summary-top-thread ()
8110 "Go to the top of the thread." 8353 "Go to the top of the thread."
8111 (interactive) 8354 (interactive)
8112 (gnus-set-global-variables)
8113 (while (gnus-summary-go-up-thread)) 8355 (while (gnus-summary-go-up-thread))
8114 (gnus-summary-article-number)) 8356 (gnus-summary-article-number))
8115 8357
@@ -8118,7 +8360,6 @@ taken."
8118If the prefix argument is positive, remove any kinds of marks. 8360If the prefix argument is positive, remove any kinds of marks.
8119If the prefix argument is negative, tick articles instead." 8361If the prefix argument is negative, tick articles instead."
8120 (interactive "P") 8362 (interactive "P")
8121 (gnus-set-global-variables)
8122 (when unmark 8363 (when unmark
8123 (setq unmark (prefix-numeric-value unmark))) 8364 (setq unmark (prefix-numeric-value unmark)))
8124 (let ((articles (gnus-summary-articles-in-thread))) 8365 (let ((articles (gnus-summary-articles-in-thread)))
@@ -8187,7 +8428,6 @@ Argument REVERSE means reverse order."
8187 8428
8188(defun gnus-summary-sort (predicate reverse) 8429(defun gnus-summary-sort (predicate reverse)
8189 "Sort summary buffer by PREDICATE. REVERSE means reverse order." 8430 "Sort summary buffer by PREDICATE. REVERSE means reverse order."
8190 (gnus-set-global-variables)
8191 (let* ((thread (intern (format "gnus-thread-sort-by-%s" predicate))) 8431 (let* ((thread (intern (format "gnus-thread-sort-by-%s" predicate)))
8192 (article (intern (format "gnus-article-sort-by-%s" predicate))) 8432 (article (intern (format "gnus-article-sort-by-%s" predicate)))
8193 (gnus-thread-sort-functions 8433 (gnus-thread-sort-functions
@@ -8220,7 +8460,6 @@ If N is nil and any articles have been marked with the process mark,
8220save those articles instead. 8460save those articles instead.
8221The variable `gnus-default-article-saver' specifies the saver function." 8461The variable `gnus-default-article-saver' specifies the saver function."
8222 (interactive "P") 8462 (interactive "P")
8223 (gnus-set-global-variables)
8224 (let* ((articles (gnus-summary-work-articles n)) 8463 (let* ((articles (gnus-summary-work-articles n))
8225 (save-buffer (save-excursion 8464 (save-buffer (save-excursion
8226 (nnheader-set-temp-buffer " *Gnus Save*"))) 8465 (nnheader-set-temp-buffer " *Gnus Save*")))
@@ -8257,7 +8496,6 @@ If N is a negative number, pipe the N previous articles.
8257If N is nil and any articles have been marked with the process mark, 8496If N is nil and any articles have been marked with the process mark,
8258pipe those articles instead." 8497pipe those articles instead."
8259 (interactive "P") 8498 (interactive "P")
8260 (gnus-set-global-variables)
8261 (let ((gnus-default-article-saver 'gnus-summary-save-in-pipe)) 8499 (let ((gnus-default-article-saver 'gnus-summary-save-in-pipe))
8262 (gnus-summary-save-article arg t)) 8500 (gnus-summary-save-article arg t))
8263 (gnus-configure-windows 'pipe)) 8501 (gnus-configure-windows 'pipe))
@@ -8269,7 +8507,6 @@ If N is a negative number, save the N previous articles.
8269If N is nil and any articles have been marked with the process mark, 8507If N is nil and any articles have been marked with the process mark,
8270save those articles instead." 8508save those articles instead."
8271 (interactive "P") 8509 (interactive "P")
8272 (gnus-set-global-variables)
8273 (let ((gnus-default-article-saver 'gnus-summary-save-in-mail)) 8510 (let ((gnus-default-article-saver 'gnus-summary-save-in-mail))
8274 (gnus-summary-save-article arg))) 8511 (gnus-summary-save-article arg)))
8275 8512
@@ -8280,7 +8517,6 @@ If N is a negative number, save the N previous articles.
8280If N is nil and any articles have been marked with the process mark, 8517If N is nil and any articles have been marked with the process mark,
8281save those articles instead." 8518save those articles instead."
8282 (interactive "P") 8519 (interactive "P")
8283 (gnus-set-global-variables)
8284 (let ((gnus-default-article-saver 'gnus-summary-save-in-rmail)) 8520 (let ((gnus-default-article-saver 'gnus-summary-save-in-rmail))
8285 (gnus-summary-save-article arg))) 8521 (gnus-summary-save-article arg)))
8286 8522
@@ -8291,7 +8527,6 @@ If N is a negative number, save the N previous articles.
8291If N is nil and any articles have been marked with the process mark, 8527If N is nil and any articles have been marked with the process mark,
8292save those articles instead." 8528save those articles instead."
8293 (interactive "P") 8529 (interactive "P")
8294 (gnus-set-global-variables)
8295 (let ((gnus-default-article-saver 'gnus-summary-save-in-file)) 8530 (let ((gnus-default-article-saver 'gnus-summary-save-in-file))
8296 (gnus-summary-save-article arg))) 8531 (gnus-summary-save-article arg)))
8297 8532
@@ -8302,7 +8537,6 @@ If N is a negative number, save the N previous articles.
8302If N is nil and any articles have been marked with the process mark, 8537If N is nil and any articles have been marked with the process mark,
8303save those articles instead." 8538save those articles instead."
8304 (interactive "P") 8539 (interactive "P")
8305 (gnus-set-global-variables)
8306 (let ((gnus-default-article-saver 'gnus-summary-write-to-file)) 8540 (let ((gnus-default-article-saver 'gnus-summary-write-to-file))
8307 (gnus-summary-save-article arg))) 8541 (gnus-summary-save-article arg)))
8308 8542
@@ -8313,17 +8547,14 @@ If N is a negative number, save the N previous articles.
8313If N is nil and any articles have been marked with the process mark, 8547If N is nil and any articles have been marked with the process mark,
8314save those articles instead." 8548save those articles instead."
8315 (interactive "P") 8549 (interactive "P")
8316 (gnus-set-global-variables)
8317 (let ((gnus-default-article-saver 'gnus-summary-save-body-in-file)) 8550 (let ((gnus-default-article-saver 'gnus-summary-save-body-in-file))
8318 (gnus-summary-save-article arg))) 8551 (gnus-summary-save-article arg)))
8319 8552
8320(defun gnus-summary-pipe-message (program) 8553(defun gnus-summary-pipe-message (program)
8321 "Pipe the current article through PROGRAM." 8554 "Pipe the current article through PROGRAM."
8322 (interactive "sProgram: ") 8555 (interactive "sProgram: ")
8323 (gnus-set-global-variables)
8324 (gnus-summary-select-article) 8556 (gnus-summary-select-article)
8325 (let ((mail-header-separator "") 8557 (let ((mail-header-separator ""))
8326 (art-buf (get-buffer gnus-article-buffer)))
8327 (gnus-eval-in-buffer-window gnus-article-buffer 8558 (gnus-eval-in-buffer-window gnus-article-buffer
8328 (save-restriction 8559 (save-restriction
8329 (widen) 8560 (widen)
@@ -8501,7 +8732,7 @@ save those articles instead."
8501 (cond ((assq 'execute props) 8732 (cond ((assq 'execute props)
8502 (gnus-execute-command (cdr (assq 'execute props))))) 8733 (gnus-execute-command (cdr (assq 'execute props)))))
8503 (let ((gnus-current-article (gnus-summary-article-number))) 8734 (let ((gnus-current-article (gnus-summary-article-number)))
8504 (run-hooks 'gnus-mark-article-hook))) 8735 (gnus-run-hooks 'gnus-mark-article-hook)))
8505 8736
8506(defun gnus-execute-command (command &optional automatic) 8737(defun gnus-execute-command (command &optional automatic)
8507 (save-excursion 8738 (save-excursion
@@ -8523,15 +8754,12 @@ save those articles instead."
8523(defun gnus-summary-edit-global-kill (article) 8754(defun gnus-summary-edit-global-kill (article)
8524 "Edit the \"global\" kill file." 8755 "Edit the \"global\" kill file."
8525 (interactive (list (gnus-summary-article-number))) 8756 (interactive (list (gnus-summary-article-number)))
8526 (gnus-set-global-variables)
8527 (gnus-group-edit-global-kill article)) 8757 (gnus-group-edit-global-kill article))
8528 8758
8529(defun gnus-summary-edit-local-kill () 8759(defun gnus-summary-edit-local-kill ()
8530 "Edit a local kill file applied to the current newsgroup." 8760 "Edit a local kill file applied to the current newsgroup."
8531 (interactive) 8761 (interactive)
8532 (gnus-set-global-variables)
8533 (setq gnus-current-headers (gnus-summary-article-header)) 8762 (setq gnus-current-headers (gnus-summary-article-header))
8534 (gnus-set-global-variables)
8535 (gnus-group-edit-local-kill 8763 (gnus-group-edit-local-kill
8536 (gnus-summary-article-number) gnus-newsgroup-name)) 8764 (gnus-summary-article-number) gnus-newsgroup-name))
8537 8765
@@ -8555,6 +8783,14 @@ save those articles instead."
8555 (not (gnus-summary-article-sparse-p (mail-header-number header)))) 8783 (not (gnus-summary-article-sparse-p (mail-header-number header))))
8556 ;; We have found the header. 8784 ;; We have found the header.
8557 header 8785 header
8786 ;; If this is a sparse article, we have to nix out its
8787 ;; previous entry in the thread hashtb.
8788 (when (and header
8789 (gnus-summary-article-sparse-p (mail-header-number header)))
8790 (let* ((parent (gnus-parent-id (mail-header-references header)))
8791 (thread (and parent (gnus-id-to-thread parent))))
8792 (when thread
8793 (delq (assq header thread) thread))))
8558 ;; We have to really fetch the header to this article. 8794 ;; We have to really fetch the header to this article.
8559 (save-excursion 8795 (save-excursion
8560 (set-buffer nntp-server-buffer) 8796 (set-buffer nntp-server-buffer)
@@ -8661,14 +8897,14 @@ save those articles instead."
8661 (setq list (cdr list)))) 8897 (setq list (cdr list))))
8662 (let ((face (cdar list))) 8898 (let ((face (cdar list)))
8663 (unless (eq face (get-text-property beg 'face)) 8899 (unless (eq face (get-text-property beg 'face))
8664 (gnus-put-text-property 8900 (gnus-put-text-property-excluding-characters-with-faces
8665 beg end 'face 8901 beg end 'face
8666 (setq face (if (boundp face) (symbol-value face) face))) 8902 (setq face (if (boundp face) (symbol-value face) face)))
8667 (when gnus-summary-highlight-line-function 8903 (when gnus-summary-highlight-line-function
8668 (funcall gnus-summary-highlight-line-function article face)))) 8904 (funcall gnus-summary-highlight-line-function article face))))
8669 (goto-char p))) 8905 (goto-char p)))
8670 8906
8671(defun gnus-update-read-articles (group unread) 8907(defun gnus-update-read-articles (group unread &optional compute)
8672 "Update the list of read articles in GROUP." 8908 "Update the list of read articles in GROUP."
8673 (let* ((active (or gnus-newsgroup-active (gnus-active group))) 8909 (let* ((active (or gnus-newsgroup-active (gnus-active group)))
8674 (entry (gnus-gethash group gnus-newsrc-hashtb)) 8910 (entry (gnus-gethash group gnus-newsrc-hashtb))
@@ -8700,20 +8936,22 @@ save those articles instead."
8700 (setq unread (cdr unread))) 8936 (setq unread (cdr unread)))
8701 (when (<= prev (cdr active)) 8937 (when (<= prev (cdr active))
8702 (push (cons prev (cdr active)) read)) 8938 (push (cons prev (cdr active)) read))
8703 (save-excursion 8939 (if compute
8704 (set-buffer gnus-group-buffer) 8940 (if (> (length read) 1) (nreverse read) read)
8705 (gnus-undo-register 8941 (save-excursion
8706 `(progn 8942 (set-buffer gnus-group-buffer)
8707 (gnus-info-set-marks ',info ',(gnus-info-marks info) t) 8943 (gnus-undo-register
8708 (gnus-info-set-read ',info ',(gnus-info-read info)) 8944 `(progn
8709 (gnus-get-unread-articles-in-group ',info (gnus-active ,group)) 8945 (gnus-info-set-marks ',info ',(gnus-info-marks info) t)
8710 (gnus-group-update-group ,group t)))) 8946 (gnus-info-set-read ',info ',(gnus-info-read info))
8711 ;; Enter this list into the group info. 8947 (gnus-get-unread-articles-in-group ',info (gnus-active ,group))
8712 (gnus-info-set-read 8948 (gnus-group-update-group ,group t))))
8713 info (if (> (length read) 1) (nreverse read) read)) 8949 ;; Enter this list into the group info.
8714 ;; Set the number of unread articles in gnus-newsrc-hashtb. 8950 (gnus-info-set-read
8715 (gnus-get-unread-articles-in-group info (gnus-active group)) 8951 info (if (> (length read) 1) (nreverse read) read))
8716 t))) 8952 ;; Set the number of unread articles in gnus-newsrc-hashtb.
8953 (gnus-get-unread-articles-in-group info (gnus-active group))
8954 t))))
8717 8955
8718(defun gnus-offer-save-summaries () 8956(defun gnus-offer-save-summaries ()
8719 "Offer to save all active summary buffers." 8957 "Offer to save all active summary buffers."
@@ -8738,7 +8976,9 @@ save those articles instead."
8738 (when buffers 8976 (when buffers
8739 (map-y-or-n-p 8977 (map-y-or-n-p
8740 "Update summary buffer %s? " 8978 "Update summary buffer %s? "
8741 (lambda (buf) (switch-to-buffer buf) (gnus-summary-exit)) 8979 (lambda (buf)
8980 (switch-to-buffer buf)
8981 (gnus-summary-exit))
8742 buffers))))) 8982 buffers)))))
8743 8983
8744(gnus-ems-redefine) 8984(gnus-ems-redefine)
diff --git a/lisp/gnus/gnus-topic.el b/lisp/gnus/gnus-topic.el
index 413a43f53a6..26b91f8072f 100644
--- a/lisp/gnus/gnus-topic.el
+++ b/lisp/gnus/gnus-topic.el
@@ -1,8 +1,8 @@
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 Free Software Foundation, Inc. 2;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Ilja Weis <kult@uni-paderborn.de> 4;; Author: Ilja Weis <kult@uni-paderborn.de>
5;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 5;; Lars Magne Ingebrigtsen <larsi@gnus.org>
6;; Keywords: news 6;; Keywords: news
7 7
8;; This file is part of GNU Emacs. 8;; This file is part of GNU Emacs.
@@ -28,9 +28,12 @@
28 28
29(eval-when-compile (require 'cl)) 29(eval-when-compile (require 'cl))
30 30
31(eval-when-compile (require 'cl))
32
31(require 'gnus) 33(require 'gnus)
32(require 'gnus-group) 34(require 'gnus-group)
33(require 'gnus-start) 35(require 'gnus-start)
36(require 'gnus-util)
34 37
35(defgroup gnus-topic nil 38(defgroup gnus-topic nil
36 "Group topics." 39 "Group topics."
@@ -73,6 +76,7 @@ with some simple extensions.
73 76
74(defvar gnus-topic-active-topology nil) 77(defvar gnus-topic-active-topology nil)
75(defvar gnus-topic-active-alist nil) 78(defvar gnus-topic-active-alist nil)
79(defvar gnus-topic-unreads nil)
76 80
77(defvar gnus-topology-checked-p nil 81(defvar gnus-topology-checked-p nil
78 "Whether the topology has been checked in this session.") 82 "Whether the topology has been checked in this session.")
@@ -108,9 +112,7 @@ with some simple extensions.
108 112
109(defun gnus-topic-unread (topic) 113(defun gnus-topic-unread (topic)
110 "Return the number of unread articles in TOPIC." 114 "Return the number of unread articles in TOPIC."
111 (or (save-excursion 115 (or (cdr (assoc topic gnus-topic-unreads))
112 (and (gnus-topic-goto-topic topic)
113 (gnus-group-topic-unread)))
114 0)) 116 0))
115 117
116(defun gnus-group-topic-p () 118(defun gnus-group-topic-p ()
@@ -166,9 +168,10 @@ with some simple extensions.
166 (when result 168 (when result
167 (symbol-name result)))) 169 (symbol-name result))))
168 170
169(defun gnus-current-topics () 171(defun gnus-current-topics (&optional topic)
170 "Return a list of all current topics, lowest in hierarchy first." 172 "Return a list of all current topics, lowest in hierarchy first.
171 (let ((topic (gnus-current-topic)) 173If TOPIC, start with that topic."
174 (let ((topic (or topic (gnus-current-topic)))
172 topics) 175 topics)
173 (while topic 176 (while topic
174 (push topic topics) 177 (push topic topics)
@@ -181,12 +184,12 @@ with some simple extensions.
181 (beginning-of-line) 184 (beginning-of-line)
182 (get-text-property (point) 'gnus-active))) 185 (get-text-property (point) 'gnus-active)))
183 186
184(defun gnus-topic-find-groups (topic &optional level all) 187(defun gnus-topic-find-groups (topic &optional level all lowest)
185 "Return entries for all visible groups in TOPIC." 188 "Return entries for all visible groups in TOPIC."
186 (let ((groups (cdr (assoc topic gnus-topic-alist))) 189 (let ((groups (cdr (assoc topic gnus-topic-alist)))
187 info clevel unread group lowest params visible-groups entry active) 190 info clevel unread group params visible-groups entry active)
188 (setq lowest (or lowest 1)) 191 (setq lowest (or lowest 1))
189 (setq level (or level 7)) 192 (setq level (or level gnus-level-unsubscribed))
190 ;; We go through the newsrc to look for matches. 193 ;; We go through the newsrc to look for matches.
191 (while groups 194 (while groups
192 (when (setq group (pop groups)) 195 (when (setq group (pop groups))
@@ -199,7 +202,8 @@ with some simple extensions.
199 active 202 active
200 (- (1+ (cdr active)) (car active)))) 203 (- (1+ (cdr active)) (car active))))
201 clevel (or (gnus-info-level info) 204 clevel (or (gnus-info-level info)
202 (if (member group gnus-zombie-list) 8 9)))) 205 (if (member group gnus-zombie-list)
206 gnus-level-zombie gnus-level-killed))))
203 (and 207 (and
204 unread ; nil means that the group is dead. 208 unread ; nil means that the group is dead.
205 (<= clevel level) 209 (<= clevel level)
@@ -324,27 +328,32 @@ with some simple extensions.
324 328
325(defun gnus-group-topic-parameters (group) 329(defun gnus-group-topic-parameters (group)
326 "Compute the group parameters for GROUP taking into account inheritance from topics." 330 "Compute the group parameters for GROUP taking into account inheritance from topics."
327 (let ((params-list (list (gnus-group-get-parameter group))) 331 (let ((params-list (copy-sequence (gnus-group-get-parameter group))))
328 topics params param out)
329 (save-excursion 332 (save-excursion
330 (gnus-group-goto-group group) 333 (gnus-group-goto-group group)
331 (setq topics (gnus-current-topics)) 334 (nconc params-list
332 (while topics 335 (gnus-topic-hierarchical-parameters (gnus-current-topic))))))
333 (push (gnus-topic-parameters (pop topics)) params-list)) 336
334 ;; We probably have lots of nil elements here, so 337(defun gnus-topic-hierarchical-parameters (topic)
335 ;; we remove them. Probably faster than doing this "properly". 338 "Return a topic list computed for TOPIC."
336 (setq params-list (delq nil params-list)) 339 (let ((topics (gnus-current-topics topic))
337 ;; Now we have all the parameters, so we go through them 340 params-list param out params)
338 ;; and do inheritance in the obvious way. 341 (while topics
339 (while (setq params (pop params-list)) 342 (push (gnus-topic-parameters (pop topics)) params-list))
340 (while (setq param (pop params)) 343 ;; We probably have lots of nil elements here, so
341 (when (atom param) 344 ;; we remove them. Probably faster than doing this "properly".
342 (setq param (cons param t))) 345 (setq params-list (delq nil params-list))
343 ;; Override any old versions of this param. 346 ;; Now we have all the parameters, so we go through them
344 (setq out (delq (assq (car param) out) out)) 347 ;; and do inheritance in the obvious way.
345 (push param out))) 348 (while (setq params (pop params-list))
346 ;; Return the resulting parameter list. 349 (while (setq param (pop params))
347 out))) 350 (when (atom param)
351 (setq param (cons param t)))
352 ;; Override any old versions of this param.
353 (gnus-pull (car param) out)
354 (push param out)))
355 ;; Return the resulting parameter list.
356 out))
348 357
349;;; General utility functions 358;;; General utility functions
350 359
@@ -355,8 +364,8 @@ with some simple extensions.
355;;; Generating group buffers 364;;; Generating group buffers
356 365
357(defun gnus-group-prepare-topics (level &optional all lowest regexp list-topic topic-level) 366(defun gnus-group-prepare-topics (level &optional all lowest regexp list-topic topic-level)
358 "List all newsgroups with unread articles of level LEVEL or lower, and 367 "List all newsgroups with unread articles of level LEVEL or lower.
359use the `gnus-group-topics' to sort the groups. 368Use the `gnus-group-topics' to sort the groups.
360If ALL is non-nil, list groups that have no unread articles. 369If ALL is non-nil, list groups that have no unread articles.
361If LOWEST is non-nil, list all newsgroups of level LOWEST or higher." 370If LOWEST is non-nil, list all newsgroups of level LOWEST or higher."
362 (set-buffer gnus-group-buffer) 371 (set-buffer gnus-group-buffer)
@@ -371,7 +380,8 @@ If LOWEST is non-nil, list all newsgroups of level LOWEST or higher."
371 (erase-buffer)) 380 (erase-buffer))
372 381
373 ;; List dead groups? 382 ;; List dead groups?
374 (when (and (>= level gnus-level-zombie) (<= lowest gnus-level-zombie)) 383 (when (and (>= level gnus-level-zombie)
384 (<= lowest gnus-level-zombie))
375 (gnus-group-prepare-flat-list-dead 385 (gnus-group-prepare-flat-list-dead
376 (setq gnus-zombie-list (sort gnus-zombie-list 'string<)) 386 (setq gnus-zombie-list (sort gnus-zombie-list 'string<))
377 gnus-level-zombie ?Z 387 gnus-level-zombie ?Z
@@ -389,20 +399,29 @@ If LOWEST is non-nil, list all newsgroups of level LOWEST or higher."
389 (if list-topic 399 (if list-topic
390 (let ((top (gnus-topic-find-topology list-topic))) 400 (let ((top (gnus-topic-find-topology list-topic)))
391 (gnus-topic-prepare-topic (cdr top) (car top) 401 (gnus-topic-prepare-topic (cdr top) (car top)
392 (or topic-level level) all)) 402 (or topic-level level) all
403 nil lowest))
393 (gnus-topic-prepare-topic gnus-topic-topology 0 404 (gnus-topic-prepare-topic gnus-topic-topology 0
394 (or topic-level level) all))) 405 (or topic-level level) all
406 nil lowest)))
395 407
396 (gnus-group-set-mode-line) 408 (gnus-group-set-mode-line)
397 (setq gnus-group-list-mode (cons level all)) 409 (setq gnus-group-list-mode (cons level all))
398 (run-hooks 'gnus-group-prepare-hook)))) 410 (gnus-run-hooks 'gnus-group-prepare-hook))))
399 411
400(defun gnus-topic-prepare-topic (topicl level &optional list-level all silent) 412(defun gnus-topic-prepare-topic (topicl level &optional list-level all silent
413 lowest)
401 "Insert TOPIC into the group buffer. 414 "Insert TOPIC into the group buffer.
402If SILENT, don't insert anything. Return the number of unread 415If SILENT, don't insert anything. Return the number of unread
403articles in the topic and its subtopics." 416articles in the topic and its subtopics."
404 (let* ((type (pop topicl)) 417 (let* ((type (pop topicl))
405 (entries (gnus-topic-find-groups (car type) list-level all)) 418 (entries (gnus-topic-find-groups
419 (car type) list-level
420 (or all
421 (cdr (assq 'visible
422 (gnus-topic-hierarchical-parameters
423 (car type)))))
424 lowest))
406 (visiblep (and (eq (nth 1 type) 'visible) (not silent))) 425 (visiblep (and (eq (nth 1 type) 'visible) (not silent)))
407 (gnus-group-indentation 426 (gnus-group-indentation
408 (make-string (* gnus-topic-indent-level level) ? )) 427 (make-string (* gnus-topic-indent-level level) ? ))
@@ -418,7 +437,7 @@ articles in the topic and its subtopics."
418 (incf unread 437 (incf unread
419 (gnus-topic-prepare-topic 438 (gnus-topic-prepare-topic
420 (pop topicl) (1+ level) list-level all 439 (pop topicl) (1+ level) list-level all
421 (not visiblep)))) 440 (not visiblep) lowest)))
422 (setq end (point)) 441 (setq end (point))
423 (goto-char beg) 442 (goto-char beg)
424 ;; Insert all the groups that belong in this topic. 443 ;; Insert all the groups that belong in this topic.
@@ -427,7 +446,7 @@ articles in the topic and its subtopics."
427 (if (stringp entry) 446 (if (stringp entry)
428 ;; Dead groups. 447 ;; Dead groups.
429 (gnus-group-insert-group-line 448 (gnus-group-insert-group-line
430 entry (if (member entry gnus-zombie-list) 8 9) 449 entry (if (member entry gnus-zombie-list) gnus-level-zombie gnus-level-killed)
431 nil (- (1+ (cdr (setq active (gnus-active entry)))) 450 nil (- (1+ (cdr (setq active (gnus-active entry))))
432 (car active)) 451 (car active))
433 nil) 452 nil)
@@ -454,6 +473,7 @@ articles in the topic and its subtopics."
454 (car type) visiblep 473 (car type) visiblep
455 (not (eq (nth 2 type) 'hidden)) 474 (not (eq (nth 2 type) 'hidden))
456 level all-entries unread)) 475 level all-entries unread))
476 (gnus-topic-update-unreads (car type) unread)
457 (goto-char end) 477 (goto-char end)
458 unread)) 478 unread))
459 479
@@ -508,7 +528,9 @@ articles in the topic and its subtopics."
508 (indentation (make-string (* gnus-topic-indent-level level) ? )) 528 (indentation (make-string (* gnus-topic-indent-level level) ? ))
509 (total-number-of-articles unread) 529 (total-number-of-articles unread)
510 (number-of-groups (length entries)) 530 (number-of-groups (length entries))
511 (active-topic (eq gnus-topic-alist gnus-topic-active-alist))) 531 (active-topic (eq gnus-topic-alist gnus-topic-active-alist))
532 gnus-tmp-header)
533 (gnus-topic-update-unreads name unread)
512 (beginning-of-line) 534 (beginning-of-line)
513 ;; Insert the text. 535 ;; Insert the text.
514 (gnus-add-text-properties 536 (gnus-add-text-properties
@@ -521,6 +543,11 @@ articles in the topic and its subtopics."
521 'gnus-active active-topic 543 'gnus-active active-topic
522 'gnus-topic-visible visiblep)))) 544 'gnus-topic-visible visiblep))))
523 545
546(defun gnus-topic-update-unreads (topic unreads)
547 (setq gnus-topic-unreads (delq (assoc topic gnus-topic-unreads)
548 gnus-topic-unreads))
549 (push (cons topic unreads) gnus-topic-unreads))
550
524(defun gnus-topic-update-topics-containing-group (group) 551(defun gnus-topic-update-topics-containing-group (group)
525 "Update all topics that have GROUP as a member." 552 "Update all topics that have GROUP as a member."
526 (when (and (eq major-mode 'gnus-group-mode) 553 (when (and (eq major-mode 'gnus-group-mode)
@@ -602,7 +629,7 @@ articles in the topic and its subtopics."
602 (parent (gnus-topic-parent-topic topic-name)) 629 (parent (gnus-topic-parent-topic topic-name))
603 (all-entries entries) 630 (all-entries entries)
604 (unread 0) 631 (unread 0)
605 old-unread entry) 632 old-unread entry new-unread)
606 (when (gnus-topic-goto-topic (car type)) 633 (when (gnus-topic-goto-topic (car type))
607 ;; Tally all the groups that belong in this topic. 634 ;; Tally all the groups that belong in this topic.
608 (if reads 635 (if reads
@@ -618,11 +645,14 @@ articles in the topic and its subtopics."
618 (car type) (gnus-topic-visible-p) 645 (car type) (gnus-topic-visible-p)
619 (not (eq (nth 2 type) 'hidden)) 646 (not (eq (nth 2 type) 'hidden))
620 (gnus-group-topic-level) all-entries unread) 647 (gnus-group-topic-level) all-entries unread)
621 (gnus-delete-line)) 648 (gnus-delete-line)
649 (forward-line -1)
650 (setq new-unread (gnus-group-topic-unread)))
622 (when parent 651 (when parent
623 (forward-line -1) 652 (forward-line -1)
624 (gnus-topic-update-topic-line 653 (gnus-topic-update-topic-line
625 parent (- old-unread (gnus-group-topic-unread)))) 654 parent
655 (- (or old-unread 0) (or new-unread 0))))
626 unread)) 656 unread))
627 657
628(defun gnus-topic-group-indentation () 658(defun gnus-topic-group-indentation ()
@@ -729,55 +759,60 @@ articles in the topic and its subtopics."
729 "Run when changing levels to enter/remove groups from topics." 759 "Run when changing levels to enter/remove groups from topics."
730 (save-excursion 760 (save-excursion
731 (set-buffer gnus-group-buffer) 761 (set-buffer gnus-group-buffer)
732 (gnus-group-goto-group (or (car (nth 2 previous)) group)) 762 (let ((buffer-read-only nil))
733 (when (and gnus-topic-mode 763 (unless gnus-topic-inhibit-change-level
734 gnus-topic-alist 764 (gnus-group-goto-group (or (car (nth 2 previous)) group))
735 (not gnus-topic-inhibit-change-level)) 765 (when (and gnus-topic-mode
736 ;; Remove the group from the topics. 766 gnus-topic-alist
737 (when (and (< oldlevel gnus-level-zombie) 767 (not gnus-topic-inhibit-change-level))
738 (>= level gnus-level-zombie)) 768 ;; Remove the group from the topics.
739 (let (alist) 769 (if (and (< oldlevel gnus-level-zombie)
740 (forward-line -1) 770 (>= level gnus-level-zombie))
741 (when (setq alist (assoc (gnus-current-topic) gnus-topic-alist)) 771 (let ((alist gnus-topic-alist))
742 (setcdr alist (gnus-delete-first group (cdr alist)))))) 772 (while (gnus-group-goto-group group)
743 ;; If the group is subscribed we enter it into the topics. 773 (gnus-delete-line))
744 (when (and (< level gnus-level-zombie) 774 (while alist
745 (>= oldlevel gnus-level-zombie)) 775 (when (member group (car alist))
746 (let* ((prev (gnus-group-group-name)) 776 (setcdr (car alist) (delete group (cdar alist))))
747 (gnus-topic-inhibit-change-level t) 777 (pop alist)))
748 (gnus-group-indentation 778 ;; If the group is subscribed we enter it into the topics.
749 (make-string 779 (when (and (< level gnus-level-zombie)
750 (* gnus-topic-indent-level 780 (>= oldlevel gnus-level-zombie))
751 (or (save-excursion 781 (let* ((prev (gnus-group-group-name))
752 (gnus-topic-goto-topic (gnus-current-topic)) 782 (gnus-topic-inhibit-change-level t)
753 (gnus-group-topic-level)) 783 (gnus-group-indentation
754 0)) 784 (make-string
755 ? )) 785 (* gnus-topic-indent-level
756 (yanked (list group)) 786 (or (save-excursion
757 alist talist end) 787 (gnus-topic-goto-topic (gnus-current-topic))
758 ;; Then we enter the yanked groups into the topics they belong 788 (gnus-group-topic-level))
759 ;; to. 789 0))
760 (when (setq alist (assoc (save-excursion 790 ? ))
761 (forward-line -1) 791 (yanked (list group))
762 (or 792 alist talist end)
763 (gnus-current-topic) 793 ;; Then we enter the yanked groups into the topics they belong
764 (caar gnus-topic-topology))) 794 ;; to.
765 gnus-topic-alist)) 795 (when (setq alist (assoc (save-excursion
766 (setq talist alist) 796 (forward-line -1)
767 (when (stringp yanked) 797 (or
768 (setq yanked (list yanked))) 798 (gnus-current-topic)
769 (if (not prev) 799 (caar gnus-topic-topology)))
770 (nconc alist yanked) 800 gnus-topic-alist))
771 (if (not (cdr alist)) 801 (setq talist alist)
772 (setcdr alist (nconc yanked (cdr alist))) 802 (when (stringp yanked)
773 (while (and (not end) (cdr alist)) 803 (setq yanked (list yanked)))
774 (when (equal (cadr alist) prev) 804 (if (not prev)
775 (setcdr alist (nconc yanked (cdr alist))) 805 (nconc alist yanked)
776 (setq end t)) 806 (if (not (cdr alist))
777 (setq alist (cdr alist))) 807 (setcdr alist (nconc yanked (cdr alist)))
778 (unless end 808 (while (and (not end) (cdr alist))
779 (nconc talist yanked)))))) 809 (when (equal (cadr alist) prev)
780 (gnus-topic-update-topic))))) 810 (setcdr alist (nconc yanked (cdr alist)))
811 (setq end t))
812 (setq alist (cdr alist)))
813 (unless end
814 (nconc talist yanked))))))
815 (gnus-topic-update-topic))))))))
781 816
782(defun gnus-topic-goto-next-group (group props) 817(defun gnus-topic-goto-next-group (group props)
783 "Go to group or the next group after group." 818 "Go to group or the next group after group."
@@ -880,6 +915,10 @@ articles in the topic and its subtopics."
880 "Gp" gnus-topic-edit-parameters 915 "Gp" gnus-topic-edit-parameters
881 "#" gnus-topic-mark-topic 916 "#" gnus-topic-mark-topic
882 "\M-#" gnus-topic-unmark-topic 917 "\M-#" gnus-topic-unmark-topic
918 [tab] gnus-topic-indent
919 [(meta tab)] gnus-topic-unindent
920 "\C-i" gnus-topic-indent
921 "\M-\C-i" gnus-topic-unindent
883 gnus-mouse-2 gnus-mouse-pick-topic) 922 gnus-mouse-2 gnus-mouse-pick-topic)
884 923
885 ;; Define a new submap. 924 ;; Define a new submap.
@@ -899,7 +938,7 @@ articles in the topic and its subtopics."
899 "r" gnus-topic-rename 938 "r" gnus-topic-rename
900 "\177" gnus-topic-delete 939 "\177" gnus-topic-delete
901 [delete] gnus-topic-delete 940 [delete] gnus-topic-delete
902 "h" gnus-topic-toggle-display-empty-topics) 941 "H" gnus-topic-toggle-display-empty-topics)
903 942
904 (gnus-define-keys (gnus-topic-sort-map "S" gnus-group-topic-map) 943 (gnus-define-keys (gnus-topic-sort-map "S" gnus-group-topic-map)
905 "s" gnus-topic-sort-groups 944 "s" gnus-topic-sort-groups
@@ -943,15 +982,12 @@ articles in the topic and its subtopics."
943 (if (null arg) (not gnus-topic-mode) 982 (if (null arg) (not gnus-topic-mode)
944 (> (prefix-numeric-value arg) 0))) 983 (> (prefix-numeric-value arg) 0)))
945 ;; Infest Gnus with topics. 984 ;; Infest Gnus with topics.
946 (if (not gnus-topic-mode) 985 (if (not gnus-topic-mode)
947 (setq gnus-goto-missing-group-function nil) 986 (setq gnus-goto-missing-group-function nil)
948 (when (gnus-visual-p 'topic-menu 'menu) 987 (when (gnus-visual-p 'topic-menu 'menu)
949 (gnus-topic-make-menu-bar)) 988 (gnus-topic-make-menu-bar))
950 (setq gnus-topic-line-format-spec 989 (gnus-set-format 'topic t)
951 (gnus-parse-format gnus-topic-line-format
952 gnus-topic-line-format-alist t))
953 (gnus-add-minor-mode 'gnus-topic-mode " Topic" gnus-topic-mode-map) 990 (gnus-add-minor-mode 'gnus-topic-mode " Topic" gnus-topic-mode-map)
954 (add-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic)
955 (add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic) 991 (add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic)
956 (set (make-local-variable 'gnus-group-prepare-function) 992 (set (make-local-variable 'gnus-group-prepare-function)
957 'gnus-group-prepare-topics) 993 'gnus-group-prepare-topics)
@@ -973,7 +1009,7 @@ articles in the topic and its subtopics."
973 ;; We check the topology. 1009 ;; We check the topology.
974 (when gnus-newsrc-alist 1010 (when gnus-newsrc-alist
975 (gnus-topic-check-topology)) 1011 (gnus-topic-check-topology))
976 (run-hooks 'gnus-topic-mode-hook)) 1012 (gnus-run-hooks 'gnus-topic-mode-hook))
977 ;; Remove topic infestation. 1013 ;; Remove topic infestation.
978 (unless gnus-topic-mode 1014 (unless gnus-topic-mode
979 (remove-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic) 1015 (remove-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic)
@@ -1178,7 +1214,7 @@ If COPYP, copy the groups instead."
1178 (if (not topic) 1214 (if (not topic)
1179 (call-interactively 'gnus-group-mark-group) 1215 (call-interactively 'gnus-group-mark-group)
1180 (save-excursion 1216 (save-excursion
1181 (let ((groups (gnus-topic-find-groups topic 9 t))) 1217 (let ((groups (gnus-topic-find-groups topic gnus-level-killed t)))
1182 (while groups 1218 (while groups
1183 (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark) 1219 (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark)
1184 (gnus-info-group (nth 2 (pop groups))))))))) 1220 (gnus-info-group (nth 2 (pop groups)))))))))
@@ -1243,6 +1279,14 @@ If COPYP, copy the groups instead."
1243 (let ((topic (gnus-current-topic))) 1279 (let ((topic (gnus-current-topic)))
1244 (list topic 1280 (list topic
1245 (read-string (format "Rename %s to: " topic))))) 1281 (read-string (format "Rename %s to: " topic)))))
1282 ;; Check whether the new name exists.
1283 (when (gnus-topic-find-topology new-name)
1284 (error "Topic '%s' already exists" new-name))
1285 ;; "nil" is an invalid name, for reasons I'd rather not go
1286 ;; into here. Trust me.
1287 (when (equal new-name "nil")
1288 (error "Invalid name: %s" nil))
1289 ;; Do the renaming.
1246 (let ((top (gnus-topic-find-topology old-name)) 1290 (let ((top (gnus-topic-find-topology old-name))
1247 (entry (assoc old-name gnus-topic-alist))) 1291 (entry (assoc old-name gnus-topic-alist)))
1248 (when top 1292 (when top
@@ -1251,7 +1295,8 @@ If COPYP, copy the groups instead."
1251 (setcar entry new-name)) 1295 (setcar entry new-name))
1252 (forward-line -1) 1296 (forward-line -1)
1253 (gnus-dribble-touch) 1297 (gnus-dribble-touch)
1254 (gnus-group-list-groups))) 1298 (gnus-group-list-groups)
1299 (forward-line 1)))
1255 1300
1256(defun gnus-topic-indent (&optional unindent) 1301(defun gnus-topic-indent (&optional unindent)
1257 "Indent a topic -- make it a sub-topic of the previous topic. 1302 "Indent a topic -- make it a sub-topic of the previous topic.
@@ -1302,7 +1347,7 @@ If FORCE, always re-read the active file."
1302 (let ((gnus-topic-topology gnus-topic-active-topology) 1347 (let ((gnus-topic-topology gnus-topic-active-topology)
1303 (gnus-topic-alist gnus-topic-active-alist) 1348 (gnus-topic-alist gnus-topic-active-alist)
1304 gnus-killed-list gnus-zombie-list) 1349 gnus-killed-list gnus-zombie-list)
1305 (gnus-group-list-groups 9 nil 1))) 1350 (gnus-group-list-groups gnus-level-killed nil 1)))
1306 1351
1307(defun gnus-topic-toggle-display-empty-topics () 1352(defun gnus-topic-toggle-display-empty-topics ()
1308 "Show/hide topics that have no unread articles." 1353 "Show/hide topics that have no unread articles."
diff --git a/lisp/gnus/gnus-undo.el b/lisp/gnus/gnus-undo.el
index b34070a3373..624b34a9916 100644
--- a/lisp/gnus/gnus-undo.el
+++ b/lisp/gnus/gnus-undo.el
@@ -1,7 +1,7 @@
1;;; gnus-undo.el --- minor mode for undoing in Gnus 1;;; gnus-undo.el --- minor mode for undoing in Gnus
2;; Copyright (C) 1996,97 Free Software Foundation, Inc. 2;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: news 5;; Keywords: news
6 6
7;; This file is part of GNU Emacs. 7;; This file is part of GNU Emacs.
@@ -25,7 +25,7 @@
25 25
26;; This package allows arbitrary undoing in Gnus buffers. As all the 26;; This package allows arbitrary undoing in Gnus buffers. As all the
27;; Gnus buffers aren't very text-oriented (what is in the buffers is 27;; Gnus buffers aren't very text-oriented (what is in the buffers is
28;; just some random representation of the actual data), normal Emacs 28;; just some arbitrary representation of the actual data), normal Emacs
29;; undoing doesn't work at all for Gnus. 29;; undoing doesn't work at all for Gnus.
30;; 30;;
31;; This package works by letting Gnus register functions for reversing 31;; This package works by letting Gnus register functions for reversing
@@ -46,14 +46,30 @@
46 46
47(eval-when-compile (require 'cl)) 47(eval-when-compile (require 'cl))
48 48
49(eval-when-compile (require 'cl))
50
49(require 'gnus-util) 51(require 'gnus-util)
50(require 'gnus) 52(require 'gnus)
53(require 'custom)
54
55(defgroup gnus-undo nil
56 "Undoing in Gnus buffers."
57 :group 'gnus)
58
59(defcustom gnus-undo-limit 2000
60 "The number of undoable actions recorded."
61 :type 'integer
62 :group 'gnus-undo)
51 63
52(defvar gnus-undo-mode nil 64(defcustom gnus-undo-mode nil
53 "Minor mode for undoing in Gnus buffers.") 65 "Minor mode for undoing in Gnus buffers."
66 :type 'boolean
67 :group 'gnus-undo)
54 68
55(defvar gnus-undo-mode-hook nil 69(defcustom gnus-undo-mode-hook nil
56 "Hook called in all `gnus-undo-mode' buffers.") 70 "Hook called in all `gnus-undo-mode' buffers."
71 :type 'hook
72 :group 'gnus-undo)
57 73
58;;; Internal variables. 74;;; Internal variables.
59 75
@@ -100,7 +116,7 @@
100 (gnus-add-minor-mode 'gnus-undo-mode "" gnus-undo-mode-map) 116 (gnus-add-minor-mode 'gnus-undo-mode "" gnus-undo-mode-map)
101 (make-local-hook 'post-command-hook) 117 (make-local-hook 'post-command-hook)
102 (add-hook 'post-command-hook 'gnus-undo-boundary nil t) 118 (add-hook 'post-command-hook 'gnus-undo-boundary nil t)
103 (run-hooks 'gnus-undo-mode-hook))) 119 (gnus-run-hooks 'gnus-undo-mode-hook)))
104 120
105;;; Interface functions. 121;;; Interface functions.
106 122
@@ -148,6 +164,11 @@ FORMS may use backtick quote syntax."
148 ;; Initialize list. 164 ;; Initialize list.
149 (t 165 (t
150 (setq gnus-undo-actions (list (list function))))) 166 (setq gnus-undo-actions (list (list function)))))
167 ;; Limit the length of the undo list.
168 (let ((next (nthcdr gnus-undo-limit gnus-undo-actions)))
169 (when next
170 (setcdr next nil)))
171 ;; We are not at a boundary...
151 (setq gnus-undo-boundary-inhibit t))) 172 (setq gnus-undo-boundary-inhibit t)))
152 173
153(defun gnus-undo (n) 174(defun gnus-undo (n)
diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el
index ee863a01cc3..8885fbd8719 100644
--- a/lisp/gnus/gnus-util.el
+++ b/lisp/gnus/gnus-util.el
@@ -1,7 +1,7 @@
1;;; gnus-util.el --- utility functions for Gnus 1;;; gnus-util.el --- utility functions for Gnus
2;; Copyright (C) 1996,97 Free Software Foundation, Inc. 2;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: news 5;; Keywords: news
6 6
7;; This file is part of GNU Emacs. 7;; This file is part of GNU Emacs.
@@ -35,9 +35,13 @@
35(require 'nnheader) 35(require 'nnheader)
36(require 'timezone) 36(require 'timezone)
37(require 'message) 37(require 'message)
38(eval-when-compile (require 'rmail))
38 39
39(eval-and-compile 40(eval-and-compile
40 (autoload 'nnmail-date-to-time "nnmail")) 41 (autoload 'nnmail-date-to-time "nnmail")
42 (autoload 'rmail-insert-rmail-file-header "rmail")
43 (autoload 'rmail-count-new-messages "rmail")
44 (autoload 'rmail-show-message "rmail"))
41 45
42(defun gnus-boundp (variable) 46(defun gnus-boundp (variable)
43 "Return non-nil if VARIABLE is bound and non-nil." 47 "Return non-nil if VARIABLE is bound and non-nil."
@@ -72,9 +76,6 @@
72 (set symbol nil)) 76 (set symbol nil))
73 symbol)) 77 symbol))
74 78
75;; modified by MORIOKA Tomohiko <morioka@jaist.ac.jp>
76;; function `substring' might cut on a middle of multi-octet
77;; character.
78(defun gnus-truncate-string (str width) 79(defun gnus-truncate-string (str width)
79 (substring str 0 width)) 80 (substring str 0 width))
80 81
@@ -90,7 +91,7 @@
90 "Return non-nil if FORM is funcallable." 91 "Return non-nil if FORM is funcallable."
91 (or (and (symbolp form) (fboundp form)) 92 (or (and (symbolp form) (fboundp form))
92 (and (listp form) (eq (car form) 'lambda)) 93 (and (listp form) (eq (car form) 'lambda))
93 (compiled-function-p form))) 94 (byte-code-function-p form)))
94 95
95(defsubst gnus-goto-char (point) 96(defsubst gnus-goto-char (point)
96 (and point (goto-char point))) 97 (and point (goto-char point)))
@@ -145,8 +146,8 @@
145 146
146(defun gnus-byte-code (func) 147(defun gnus-byte-code (func)
147 "Return a form that can be `eval'ed based on FUNC." 148 "Return a form that can be `eval'ed based on FUNC."
148 (let ((fval (symbol-function func))) 149 (let ((fval (indirect-function func)))
149 (if (compiled-function-p fval) 150 (if (byte-code-function-p fval)
150 (let ((flist (append fval nil))) 151 (let ((flist (append fval nil)))
151 (setcar flist 'byte-code) 152 (setcar flist 'byte-code)
152 flist) 153 flist)
@@ -161,7 +162,6 @@
161 (setq address (substring from (match-beginning 0) (match-end 0)))) 162 (setq address (substring from (match-beginning 0) (match-end 0))))
162 ;; Then we check whether the "name <address>" format is used. 163 ;; Then we check whether the "name <address>" format is used.
163 (and address 164 (and address
164 ;; Fix by MORIOKA Tomohiko <morioka@jaist.ac.jp>
165 ;; Linear white space is not required. 165 ;; Linear white space is not required.
166 (string-match (concat "[ \t]*<" (regexp-quote address) ">") from) 166 (string-match (concat "[ \t]*<" (regexp-quote address) ">") from)
167 (and (setq name (substring from 0 (match-beginning 0))) 167 (and (setq name (substring from 0 (match-beginning 0)))
@@ -175,7 +175,6 @@
175 (1- (match-end 0))))) 175 (1- (match-end 0)))))
176 (and (string-match "()" from) 176 (and (string-match "()" from)
177 (setq name address)) 177 (setq name address))
178 ;; Fix by MORIOKA Tomohiko <morioka@jaist.ac.jp>.
179 ;; XOVER might not support folded From headers. 178 ;; XOVER might not support folded From headers.
180 (and (string-match "(.*" from) 179 (and (string-match "(.*" from)
181 (setq name (substring from (1+ (match-beginning 0)) 180 (setq name (substring from (1+ (match-beginning 0))
@@ -342,12 +341,11 @@
342 (yes-or-no-p prompt) 341 (yes-or-no-p prompt)
343 (message ""))) 342 (message "")))
344 343
345;; I suspect there's a better way, but I haven't taken the time to do
346;; it yet. -erik selberg@cs.washington.edu
347(defun gnus-dd-mmm (messy-date) 344(defun gnus-dd-mmm (messy-date)
348 "Return a string like DD-MMM from a big messy string" 345 "Return a string like DD-MMM from a big messy string."
349 (let ((datevec (ignore-errors (timezone-parse-date messy-date)))) 346 (let ((datevec (ignore-errors (timezone-parse-date messy-date))))
350 (if (not datevec) 347 (if (or (not datevec)
348 (string-equal "0" (aref datevec 1)))
351 "??-???" 349 "??-???"
352 (format "%2s-%s" 350 (format "%2s-%s"
353 (condition-case () 351 (condition-case ()
@@ -378,10 +376,10 @@ Cache the result as a text property stored in DATE."
378 "Return a string of TIME in YYMMDDTHHMMSS format." 376 "Return a string of TIME in YYMMDDTHHMMSS format."
379 (format-time-string "%Y%m%dT%H%M%S" time)) 377 (format-time-string "%Y%m%dT%H%M%S" time))
380 378
381(defun gnus-date-iso8601 (header) 379(defun gnus-date-iso8601 (date)
382 "Convert the date field in HEADER to YYMMDDTHHMMSS" 380 "Convert the DATE to YYMMDDTHHMMSS."
383 (condition-case () 381 (condition-case ()
384 (gnus-time-iso8601 (gnus-date-get-time (mail-header-date header))) 382 (gnus-time-iso8601 (gnus-date-get-time date))
385 (error ""))) 383 (error "")))
386 384
387(defun gnus-mode-string-quote (string) 385(defun gnus-mode-string-quote (string)
@@ -458,9 +456,7 @@ jabbering all the time."
458If N, return the Nth ancestor instead." 456If N, return the Nth ancestor instead."
459 (when references 457 (when references
460 (let ((ids (inline (gnus-split-references references)))) 458 (let ((ids (inline (gnus-split-references references))))
461 (while (nthcdr (or n 1) ids) 459 (car (last ids (or n 1))))))
462 (setq ids (cdr ids)))
463 (car ids))))
464 460
465(defsubst gnus-buffer-live-p (buffer) 461(defsubst gnus-buffer-live-p (buffer)
466 "Say whether BUFFER is alive or not." 462 "Say whether BUFFER is alive or not."
@@ -475,22 +471,23 @@ If N, return the Nth ancestor instead."
475 (let* ((orig (point)) 471 (let* ((orig (point))
476 (end (window-end (get-buffer-window (current-buffer) t))) 472 (end (window-end (get-buffer-window (current-buffer) t)))
477 (max 0)) 473 (max 0))
478 ;; Find the longest line currently displayed in the window. 474 (when end
479 (goto-char (window-start)) 475 ;; Find the longest line currently displayed in the window.
480 (while (and (not (eobp)) 476 (goto-char (window-start))
481 (< (point) end)) 477 (while (and (not (eobp))
482 (end-of-line) 478 (< (point) end))
483 (setq max (max max (current-column))) 479 (end-of-line)
484 (forward-line 1)) 480 (setq max (max max (current-column)))
485 (goto-char orig) 481 (forward-line 1))
486 ;; Scroll horizontally to center (sort of) the point. 482 (goto-char orig)
487 (if (> max (window-width)) 483 ;; Scroll horizontally to center (sort of) the point.
488 (set-window-hscroll 484 (if (> max (window-width))
489 (get-buffer-window (current-buffer) t) 485 (set-window-hscroll
490 (min (- (current-column) (/ (window-width) 3)) 486 (get-buffer-window (current-buffer) t)
491 (+ 2 (- max (window-width))))) 487 (min (- (current-column) (/ (window-width) 3))
492 (set-window-hscroll (get-buffer-window (current-buffer) t) 0)) 488 (+ 2 (- max (window-width)))))
493 max))) 489 (set-window-hscroll (get-buffer-window (current-buffer) t) 0))
490 max))))
494 491
495(defun gnus-read-event-char () 492(defun gnus-read-event-char ()
496 "Get the next event." 493 "Get the next event."
@@ -528,12 +525,11 @@ Timezone package is used."
528 525
529(defun gnus-kill-all-overlays () 526(defun gnus-kill-all-overlays ()
530 "Delete all overlays in the current buffer." 527 "Delete all overlays in the current buffer."
531 (unless gnus-xemacs 528 (let* ((overlayss (overlay-lists))
532 (let* ((overlayss (overlay-lists)) 529 (buffer-read-only nil)
533 (buffer-read-only nil) 530 (overlays (delq nil (nconc (car overlayss) (cdr overlayss)))))
534 (overlays (delq nil (nconc (car overlayss) (cdr overlayss))))) 531 (while overlays
535 (while overlays 532 (delete-overlay (pop overlays)))))
536 (delete-overlay (pop overlays))))))
537 533
538(defvar gnus-work-buffer " *gnus work*") 534(defvar gnus-work-buffer " *gnus work*")
539 535
@@ -543,7 +539,7 @@ Timezone package is used."
543 (progn 539 (progn
544 (set-buffer gnus-work-buffer) 540 (set-buffer gnus-work-buffer)
545 (erase-buffer)) 541 (erase-buffer))
546 (set-buffer (get-buffer-create gnus-work-buffer)) 542 (set-buffer (gnus-get-buffer-create gnus-work-buffer))
547 (kill-all-local-variables) 543 (kill-all-local-variables)
548 (buffer-disable-undo (current-buffer)))) 544 (buffer-disable-undo (current-buffer))))
549 545
@@ -580,14 +576,17 @@ Timezone package is used."
580 576
581(defun gnus-prin1 (form) 577(defun gnus-prin1 (form)
582 "Use `prin1' on FORM in the current buffer. 578 "Use `prin1' on FORM in the current buffer.
583Bind `print-quoted' to t while printing." 579Bind `print-quoted' and `print-readably' to t while printing."
584 (let ((print-quoted t) 580 (let ((print-quoted t)
581 (print-readably t)
582 (print-escape-multibyte nil)
585 print-level print-length) 583 print-level print-length)
586 (prin1 form (current-buffer)))) 584 (prin1 form (current-buffer))))
587 585
588(defun gnus-prin1-to-string (form) 586(defun gnus-prin1-to-string (form)
589 "The same as `prin1', but but `print-quoted' to t." 587 "The same as `prin1', but bind `print-quoted' and `print-readably' to t."
590 (let ((print-quoted t)) 588 (let ((print-quoted t)
589 (print-readably t))
591 (prin1-to-string form))) 590 (prin1-to-string form)))
592 591
593(defun gnus-make-directory (directory) 592(defun gnus-make-directory (directory)
@@ -604,14 +603,6 @@ Bind `print-quoted' to t while printing."
604 ;; Write the buffer. 603 ;; Write the buffer.
605 (write-region (point-min) (point-max) file nil 'quietly)) 604 (write-region (point-min) (point-max) file nil 'quietly))
606 605
607(defmacro gnus-delete-assq (key list)
608 `(let ((listval (eval ,list)))
609 (setq ,list (delq (assq ,key listval) listval))))
610
611(defmacro gnus-delete-assoc (key list)
612 `(let ((listval ,list))
613 (setq ,list (delq (assoc ,key listval) listval))))
614
615(defun gnus-delete-file (file) 606(defun gnus-delete-file (file)
616 "Delete FILE if it exists." 607 "Delete FILE if it exists."
617 (when (file-exists-p file) 608 (when (file-exists-p file)
@@ -630,9 +621,21 @@ Bind `print-quoted' to t while printing."
630 (save-restriction 621 (save-restriction
631 (goto-char beg) 622 (goto-char beg)
632 (while (re-search-forward "[ \t]*\n" end 'move) 623 (while (re-search-forward "[ \t]*\n" end 'move)
633 (put-text-property beg (match-beginning 0) prop val) 624 (gnus-put-text-property beg (match-beginning 0) prop val)
634 (setq beg (point))) 625 (setq beg (point)))
635 (put-text-property beg (point) prop val))))) 626 (gnus-put-text-property beg (point) prop val)))))
627
628(defun gnus-put-text-property-excluding-characters-with-faces (beg end
629 prop val)
630 "The same as `put-text-property', but don't put props on characters with the `gnus-face' property."
631 (let ((b beg))
632 (while (/= b end)
633 (when (get-text-property b 'gnus-face)
634 (setq b (next-single-property-change b 'gnus-face nil end)))
635 (when (/= b end)
636 (gnus-put-text-property
637 b (setq b (next-single-property-change b 'gnus-face nil end))
638 prop val)))))
636 639
637;;; Protected and atomic operations. dmoore@ucsd.edu 21.11.1996 640;;; Protected and atomic operations. dmoore@ucsd.edu 21.11.1996
638;;; The primary idea here is to try to protect internal datastructures 641;;; The primary idea here is to try to protect internal datastructures
@@ -755,13 +758,15 @@ with potentially long computations."
755 (when msg 758 (when msg
756 (goto-char (point-min)) 759 (goto-char (point-min))
757 (widen) 760 (widen)
758 (search-backward "\n\^_") 761 (search-backward "\n\^_")
759 (narrow-to-region (point) (point-max)) 762 (narrow-to-region (point) (point-max))
763 (rmail-count-new-messages t)
764 (when (rmail-summary-exists)
765 (rmail-select-summary
766 (rmail-update-summary)))
760 (rmail-count-new-messages t) 767 (rmail-count-new-messages t)
761 (if (rmail-summary-exists) 768 (rmail-show-message msg))
762 (rmail-select-summary 769 (save-buffer)))))
763 (rmail-update-summary)))
764 (rmail-show-message msg))))))
765 (kill-buffer tmpbuf))) 770 (kill-buffer tmpbuf)))
766 771
767(defun gnus-output-to-mail (filename &optional ask) 772(defun gnus-output-to-mail (filename &optional ask)
@@ -829,6 +834,155 @@ with potentially long computations."
829 (goto-char (point-max)) 834 (goto-char (point-max))
830 (insert "\^_"))) 835 (insert "\^_")))
831 836
837(defun gnus-map-function (funs arg)
838 "Applies the result of the first function in FUNS to the second, and so on.
839ARG is passed to the first function."
840 (let ((myfuns funs))
841 (while myfuns
842 (setq arg (funcall (pop myfuns) arg)))
843 arg))
844
845(defun gnus-run-hooks (&rest funcs)
846 "Does the same as `run-hooks', but saves excursion."
847 (let ((buf (current-buffer)))
848 (unwind-protect
849 (apply 'run-hooks funcs)
850 (set-buffer buf))))
851
852;;;
853;;; .netrc and .authinforc parsing
854;;;
855
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)
873 "Parse FILE and return an list of all entries in the file."
874 (if (not (file-exists-p file))
875 ()
876 (save-excursion
877 (let ((tokens '("machine" "default" "login"
878 "password" "account" "macdef" "force"))
879 alist elem result pair)
880 (nnheader-set-temp-buffer " *netrc*")
881 (unwind-protect
882 (progn
883 (set-syntax-table gnus-netrc-syntax-table)
884 (insert-file-contents file)
885 (goto-char (point-min))
886 ;; Go through the file, line by line.
887 (while (not (eobp))
888 (narrow-to-region (point) (gnus-point-at-eol))
889 ;; For each line, get the tokens and values.
890 (while (not (eobp))
891 (skip-chars-forward "\t ")
892 (unless (eobp)
893 (setq elem (buffer-substring
894 (point) (progn (forward-sexp 1) (point))))
895 (cond
896 ((equal elem "macdef")
897 ;; We skip past the macro definition.
898 (widen)
899 (while (and (zerop (forward-line 1))
900 (looking-at "$")))
901 (narrow-to-region (point) (point)))
902 ((member elem tokens)
903 ;; Tokens that don't have a following value are ignored,
904 ;; except "default".
905 (when (and pair (or (cdr pair)
906 (equal (car pair) "default")))
907 (push pair alist))
908 (setq pair (list elem)))
909 (t
910 ;; Values that haven't got a preceding token are ignored.
911 (when pair
912 (setcdr pair elem)
913 (push pair alist)
914 (setq pair nil))))))
915 (if alist
916 (push (nreverse alist) result))
917 (setq alist nil
918 pair nil)
919 (widen)
920 (forward-line 1))
921 (nreverse result))
922 (kill-buffer " *netrc*"))))))
923
924(defun gnus-netrc-machine (list machine)
925 "Return the netrc values from LIST for MACHINE or for the default entry."
926 (let ((rest list))
927 (while (and list
928 (not (equal (cdr (assoc "machine" (car list))) machine)))
929 (pop list))
930 (car (or list
931 (progn (while (and rest (not (assoc "default" (car rest))))
932 (pop rest))
933 rest)))))
934
935(defun gnus-netrc-get (alist type)
936 "Return the value of token TYPE from ALIST."
937 (cdr (assoc type alist)))
938
939;;; Various
940
941(defvar gnus-group-buffer) ; Compiler directive
942(defun gnus-alive-p ()
943 "Say whether Gnus is running or not."
944 (and (boundp 'gnus-group-buffer)
945 (get-buffer gnus-group-buffer)
946 (save-excursion
947 (set-buffer gnus-group-buffer)
948 (eq major-mode 'gnus-group-mode))))
949
950(defun gnus-remove-duplicates (list)
951 (let (new (tail list))
952 (while tail
953 (or (member (car tail) new)
954 (setq new (cons (car tail) new)))
955 (setq tail (cdr tail)))
956 (nreverse new)))
957
958(defun gnus-delete-if (predicate list)
959 "Delete elements from LIST that satisfy PREDICATE."
960 (let (out)
961 (while list
962 (unless (funcall predicate (car list))
963 (push (car list) out))
964 (pop list))
965 (nreverse out)))
966
967(defun gnus-delete-alist (key alist)
968 "Delete all entries in ALIST that have a key eq to KEY."
969 (let (entry)
970 (while (setq entry (assq key alist))
971 (setq alist (delq entry alist)))
972 alist))
973
974(defmacro gnus-pull (key alist)
975 "Modify ALIST to be without KEY."
976 (unless (symbolp alist)
977 (error "Not a symbol: %s" alist))
978 `(setq ,alist (delq (assq ,key ,alist) ,alist)))
979
980(defun gnus-globalify-regexp (re)
981 "Returns a regexp that matches a whole line, iff RE matches a part of it."
982 (concat (unless (string-match "^\\^" re) "^.*")
983 re
984 (unless (string-match "\\$$" re) ".*$")))
985
832(provide 'gnus-util) 986(provide 'gnus-util)
833 987
834;;; gnus-util.el ends here 988;;; gnus-util.el ends here
diff --git a/lisp/gnus/gnus-uu.el b/lisp/gnus/gnus-uu.el
index 48c502d251d..abea681013a 100644
--- a/lisp/gnus/gnus-uu.el
+++ b/lisp/gnus/gnus-uu.el
@@ -1,7 +1,7 @@
1;;; gnus-uu.el --- extract (uu)encoded files in Gnus 1;;; gnus-uu.el --- extract (uu)encoded files in Gnus
2;; Copyright (C) 1985,86,87,93,94,95,96,97 Free Software Foundation, Inc. 2;; Copyright (C) 1985,86,87,93,94,95,96,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Created: 2 Oct 1993 5;; Created: 2 Oct 1993
6;; Keyword: news 6;; Keyword: news
7 7
@@ -28,6 +28,8 @@
28 28
29(eval-when-compile (require 'cl)) 29(eval-when-compile (require 'cl))
30 30
31(eval-when-compile (require 'cl))
32
31(require 'gnus) 33(require 'gnus)
32(require 'gnus-art) 34(require 'gnus-art)
33(require 'message) 35(require 'message)
@@ -54,8 +56,8 @@
54;; Default viewing action rules 56;; Default viewing action rules
55 57
56(defcustom gnus-uu-default-view-rules 58(defcustom gnus-uu-default-view-rules
57 '(("\\.te?xt$\\|\\.doc$\\|read.*me\\|\\.c?$\\|\\.h$\\|\\.bat$\\|\\.asm$\\|makefile" "cat %s | sed s/\r//g") 59 '(("\\.te?xt$\\|\\.doc$\\|read.*me\\|\\.c?$\\|\\.h$\\|\\.bat$\\|\\.asm$\\|makefile" "cat %s | sed 's/\r$//'")
58 ("\\.pas$" "cat %s | sed s/\r//g") 60 ("\\.pas$" "cat %s | sed 's/\r$//'")
59 ("\\.[1-9]$" "groff -mandoc -Tascii %s | sed s/\b.//g") 61 ("\\.[1-9]$" "groff -mandoc -Tascii %s | sed s/\b.//g")
60 ("\\.\\(jpe?g\\|gif\\|tiff?\\|p[pgb]m\\|xwd\\|xbm\\|pcx\\)$" "xv") 62 ("\\.\\(jpe?g\\|gif\\|tiff?\\|p[pgb]m\\|xwd\\|xbm\\|pcx\\)$" "xv")
61 ("\\.tga$" "tgatoppm %s | xv -") 63 ("\\.tga$" "tgatoppm %s | xv -")
@@ -71,7 +73,7 @@
71 ("\\.\\(flc\\|fli\\|rle\\|iff\\|pfx\\|avi\\|sme\\|rpza\\|dl\\|qt\\|rsrc\\|mov\\)$" "xanim") 73 ("\\.\\(flc\\|fli\\|rle\\|iff\\|pfx\\|avi\\|sme\\|rpza\\|dl\\|qt\\|rsrc\\|mov\\)$" "xanim")
72 ("\\.\\(tar\\|arj\\|zip\\|zoo\\|arc\\|gz\\|Z\\|lzh\\|ar\\|lha\\)$" 74 ("\\.\\(tar\\|arj\\|zip\\|zoo\\|arc\\|gz\\|Z\\|lzh\\|ar\\|lha\\)$"
73 "gnus-uu-archive")) 75 "gnus-uu-archive"))
74 "Default actions to be taken when the user asks to view a file. 76 "*Default actions to be taken when the user asks to view a file.
75To change the behaviour, you can either edit this variable or set 77To change the behaviour, you can either edit this variable or set
76`gnus-uu-user-view-rules' to something useful. 78`gnus-uu-user-view-rules' to something useful.
77 79
@@ -111,7 +113,7 @@ details."
111 113
112(defcustom gnus-uu-user-view-rules-end 114(defcustom gnus-uu-user-view-rules-end
113 '(("" "file")) 115 '(("" "file"))
114 "What actions are to be taken if no rule matched the file name. 116 "*What actions are to be taken if no rule matched the file name.
115See the documentation on the `gnus-uu-default-view-rules' variable for 117See the documentation on the `gnus-uu-default-view-rules' variable for
116details." 118details."
117 :group 'gnus-extract-view 119 :group 'gnus-extract-view
@@ -129,7 +131,7 @@ details."
129 ("\\.Z$" "uncompress") 131 ("\\.Z$" "uncompress")
130 ("\\.gz$" "gunzip") 132 ("\\.gz$" "gunzip")
131 ("\\.arc$" "arc -x")) 133 ("\\.arc$" "arc -x"))
132 "See `gnus-uu-user-archive-rules'." 134 "*See `gnus-uu-user-archive-rules'."
133 :group 'gnus-extract-archive 135 :group 'gnus-extract-archive
134 :type '(repeat (group regexp (string :tag "Command")))) 136 :type '(repeat (group regexp (string :tag "Command"))))
135 137
@@ -283,10 +285,15 @@ so I simply dropped them."
283 :group 'gnus-extract 285 :group 'gnus-extract
284 :type 'boolean) 286 :type 'boolean)
285 287
288(defcustom gnus-uu-pre-uudecode-hook nil
289 "Hook run before sending a message to uudecode."
290 :group 'gnus-extract
291 :type 'hook)
292
286(defcustom gnus-uu-digest-headers 293(defcustom gnus-uu-digest-headers
287 '("^Date:" "^From:" "^To:" "^Cc:" "^Subject:" "^Message-ID:" "^Keywords:" 294 '("^Date:" "^From:" "^To:" "^Cc:" "^Subject:" "^Message-ID:" "^Keywords:"
288 "^Summary:" "^References:") 295 "^Summary:" "^References:" "^Content-Type:" "^Content-Transfer-Encoding:")
289 "List of regexps to match headers included in digested messages. 296 "*List of regexps to match headers included in digested messages.
290The headers will be included in the sequence they are matched." 297The headers will be included in the sequence they are matched."
291 :group 'gnus-extract 298 :group 'gnus-extract
292 :type '(repeat regexp)) 299 :type '(repeat regexp))
@@ -309,10 +316,10 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
309 316
310(defvar gnus-uu-saved-article-name nil) 317(defvar gnus-uu-saved-article-name nil)
311 318
312(defconst gnus-uu-begin-string "^begin[ \t]+[0-7][0-7][0-7][ \t]+\\(.*\\)$") 319(defvar gnus-uu-begin-string "^begin[ \t]+[0-7][0-7][0-7][ \t]+\\(.*\\)$")
313(defconst gnus-uu-end-string "^end[ \t]*$") 320(defvar gnus-uu-end-string "^end[ \t]*$")
314 321
315(defconst gnus-uu-body-line "^M") 322(defvar gnus-uu-body-line "^M")
316(let ((i 61)) 323(let ((i 61))
317 (while (> (setq i (1- i)) 0) 324 (while (> (setq i (1- i)) 0)
318 (setq gnus-uu-body-line (concat gnus-uu-body-line "[^a-z]"))) 325 (setq gnus-uu-body-line (concat gnus-uu-body-line "[^a-z]")))
@@ -320,21 +327,21 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
320 327
321;"^M.............................................................?$" 328;"^M.............................................................?$"
322 329
323(defconst gnus-uu-shar-begin-string "^#! */bin/sh") 330(defvar gnus-uu-shar-begin-string "^#! */bin/sh")
324 331
325(defvar gnus-uu-shar-file-name nil) 332(defvar gnus-uu-shar-file-name nil)
326(defconst gnus-uu-shar-name-marker "begin [0-7][0-7][0-7][ \t]+\\(\\(\\w\\|\\.\\)*\\b\\)") 333(defvar gnus-uu-shar-name-marker "begin [0-7][0-7][0-7][ \t]+\\(\\(\\w\\|\\.\\)*\\b\\)")
327 334
328(defconst gnus-uu-postscript-begin-string "^%!PS-") 335(defvar gnus-uu-postscript-begin-string "^%!PS-")
329(defconst gnus-uu-postscript-end-string "^%%EOF$") 336(defvar gnus-uu-postscript-end-string "^%%EOF$")
330 337
331(defvar gnus-uu-file-name nil) 338(defvar gnus-uu-file-name nil)
332(defconst gnus-uu-uudecode-process nil) 339(defvar gnus-uu-uudecode-process nil)
333(defvar gnus-uu-binhex-article-name nil) 340(defvar gnus-uu-binhex-article-name nil)
334 341
335(defvar gnus-uu-work-dir nil) 342(defvar gnus-uu-work-dir nil)
336 343
337(defconst gnus-uu-output-buffer-name " *Gnus UU Output*") 344(defvar gnus-uu-output-buffer-name " *Gnus UU Output*")
338 345
339(defvar gnus-uu-default-dir gnus-article-save-directory) 346(defvar gnus-uu-default-dir gnus-article-save-directory)
340(defvar gnus-uu-digest-from-subject nil) 347(defvar gnus-uu-digest-from-subject nil)
@@ -348,7 +355,9 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
348 "v" gnus-uu-mark-over 355 "v" gnus-uu-mark-over
349 "s" gnus-uu-mark-series 356 "s" gnus-uu-mark-series
350 "r" gnus-uu-mark-region 357 "r" gnus-uu-mark-region
358 "g" gnus-uu-unmark-region
351 "R" gnus-uu-mark-by-regexp 359 "R" gnus-uu-mark-by-regexp
360 "G" gnus-uu-unmark-by-regexp
352 "t" gnus-uu-mark-thread 361 "t" gnus-uu-mark-thread
353 "T" gnus-uu-unmark-thread 362 "T" gnus-uu-unmark-thread
354 "a" gnus-uu-mark-all 363 "a" gnus-uu-mark-all
@@ -506,12 +515,12 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
506 (interactive "P") 515 (interactive "P")
507 (let ((gnus-uu-save-in-digest t) 516 (let ((gnus-uu-save-in-digest t)
508 (file (make-temp-name (nnheader-concat gnus-uu-tmp-dir "forward"))) 517 (file (make-temp-name (nnheader-concat gnus-uu-tmp-dir "forward")))
509 buf subject from newsgroups) 518 buf subject from)
510 (gnus-setup-message 'forward 519 (gnus-setup-message 'forward
511 (setq gnus-uu-digest-from-subject nil) 520 (setq gnus-uu-digest-from-subject nil)
512 (gnus-uu-decode-save n file) 521 (gnus-uu-decode-save n file)
513 (setq buf (switch-to-buffer (get-buffer-create " *gnus-uu-forward*"))) 522 (setq buf (switch-to-buffer
514 (gnus-add-current-to-buffer-list) 523 (gnus-get-buffer-create " *gnus-uu-forward*")))
515 (erase-buffer) 524 (erase-buffer)
516 (insert-file file) 525 (insert-file file)
517 (let ((fs gnus-uu-digest-from-subject)) 526 (let ((fs gnus-uu-digest-from-subject))
@@ -558,7 +567,6 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
558(defun gnus-uu-mark-by-regexp (regexp &optional unmark) 567(defun gnus-uu-mark-by-regexp (regexp &optional unmark)
559 "Ask for a regular expression and set the process mark on all articles that match." 568 "Ask for a regular expression and set the process mark on all articles that match."
560 (interactive (list (read-from-minibuffer "Mark (regexp): "))) 569 (interactive (list (read-from-minibuffer "Mark (regexp): ")))
561 (gnus-set-global-variables)
562 (let ((articles (gnus-uu-find-articles-matching regexp))) 570 (let ((articles (gnus-uu-find-articles-matching regexp)))
563 (while articles 571 (while articles
564 (if unmark 572 (if unmark
@@ -575,7 +583,6 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
575(defun gnus-uu-mark-series () 583(defun gnus-uu-mark-series ()
576 "Mark the current series with the process mark." 584 "Mark the current series with the process mark."
577 (interactive) 585 (interactive)
578 (gnus-set-global-variables)
579 (let ((articles (gnus-uu-find-articles-matching))) 586 (let ((articles (gnus-uu-find-articles-matching)))
580 (while articles 587 (while articles
581 (gnus-summary-set-process-mark (car articles)) 588 (gnus-summary-set-process-mark (car articles))
@@ -586,7 +593,6 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
586(defun gnus-uu-mark-region (beg end &optional unmark) 593(defun gnus-uu-mark-region (beg end &optional unmark)
587 "Set the process mark on all articles between point and mark." 594 "Set the process mark on all articles between point and mark."
588 (interactive "r") 595 (interactive "r")
589 (gnus-set-global-variables)
590 (save-excursion 596 (save-excursion
591 (goto-char beg) 597 (goto-char beg)
592 (while (< (point) end) 598 (while (< (point) end)
@@ -614,7 +620,6 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
614(defun gnus-uu-mark-thread () 620(defun gnus-uu-mark-thread ()
615 "Marks all articles downwards in this thread." 621 "Marks all articles downwards in this thread."
616 (interactive) 622 (interactive)
617 (gnus-set-global-variables)
618 (let ((level (gnus-summary-thread-level))) 623 (let ((level (gnus-summary-thread-level)))
619 (while (and (gnus-summary-set-process-mark (gnus-summary-article-number)) 624 (while (and (gnus-summary-set-process-mark (gnus-summary-article-number))
620 (zerop (gnus-summary-next-subject 1)) 625 (zerop (gnus-summary-next-subject 1))
@@ -624,7 +629,6 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
624(defun gnus-uu-unmark-thread () 629(defun gnus-uu-unmark-thread ()
625 "Unmarks all articles downwards in this thread." 630 "Unmarks all articles downwards in this thread."
626 (interactive) 631 (interactive)
627 (gnus-set-global-variables)
628 (let ((level (gnus-summary-thread-level))) 632 (let ((level (gnus-summary-thread-level)))
629 (while (and (gnus-summary-remove-process-mark 633 (while (and (gnus-summary-remove-process-mark
630 (gnus-summary-article-number)) 634 (gnus-summary-article-number))
@@ -634,8 +638,9 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
634 638
635(defun gnus-uu-invert-processable () 639(defun gnus-uu-invert-processable ()
636 "Invert the list of process-marked articles." 640 "Invert the list of process-marked articles."
641 (interactive)
637 (let ((data gnus-newsgroup-data) 642 (let ((data gnus-newsgroup-data)
638 d number) 643 number)
639 (save-excursion 644 (save-excursion
640 (while data 645 (while data
641 (if (memq (setq number (gnus-data-number (pop data))) 646 (if (memq (setq number (gnus-data-number (pop data)))
@@ -645,7 +650,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
645 (gnus-summary-position-point)) 650 (gnus-summary-position-point))
646 651
647(defun gnus-uu-mark-over (&optional score) 652(defun gnus-uu-mark-over (&optional score)
648 "Mark all articles with a score over SCORE (the prefix.)" 653 "Mark all articles with a score over SCORE (the prefix)."
649 (interactive "P") 654 (interactive "P")
650 (let ((score (gnus-score-default score)) 655 (let ((score (gnus-score-default score))
651 (data gnus-newsgroup-data)) 656 (data gnus-newsgroup-data))
@@ -662,7 +667,6 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
662(defun gnus-uu-mark-sparse () 667(defun gnus-uu-mark-sparse ()
663 "Mark all series that have some articles marked." 668 "Mark all series that have some articles marked."
664 (interactive) 669 (interactive)
665 (gnus-set-global-variables)
666 (let ((marked (nreverse gnus-newsgroup-processable)) 670 (let ((marked (nreverse gnus-newsgroup-processable))
667 subject articles total headers) 671 subject articles total headers)
668 (unless marked 672 (unless marked
@@ -687,7 +691,6 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
687(defun gnus-uu-mark-all () 691(defun gnus-uu-mark-all ()
688 "Mark all articles in \"series\" order." 692 "Mark all articles in \"series\" order."
689 (interactive) 693 (interactive)
690 (gnus-set-global-variables)
691 (setq gnus-newsgroup-processable nil) 694 (setq gnus-newsgroup-processable nil)
692 (save-excursion 695 (save-excursion
693 (let ((data gnus-newsgroup-data) 696 (let ((data gnus-newsgroup-data)
@@ -827,16 +830,15 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
827 (mail-header-subject header)) 830 (mail-header-subject header))
828 gnus-uu-digest-from-subject)) 831 gnus-uu-digest-from-subject))
829 (let ((name (file-name-nondirectory gnus-uu-saved-article-name)) 832 (let ((name (file-name-nondirectory gnus-uu-saved-article-name))
830 (delim (concat "^" (make-string 30 ?-) "$"))
831 beg subj headers headline sorthead body end-string state) 833 beg subj headers headline sorthead body end-string state)
832 (if (or (eq in-state 'first) 834 (if (or (eq in-state 'first)
833 (eq in-state 'first-and-last)) 835 (eq in-state 'first-and-last))
834 (progn 836 (progn
835 (setq state (list 'begin)) 837 (setq state (list 'begin))
836 (save-excursion (set-buffer (get-buffer-create "*gnus-uu-body*")) 838 (save-excursion (set-buffer (gnus-get-buffer-create "*gnus-uu-body*"))
837 (erase-buffer)) 839 (erase-buffer))
838 (save-excursion 840 (save-excursion
839 (set-buffer (get-buffer-create "*gnus-uu-pre*")) 841 (set-buffer (gnus-get-buffer-create "*gnus-uu-pre*"))
840 (erase-buffer) 842 (erase-buffer)
841 (insert (format 843 (insert (format
842 "Date: %s\nFrom: %s\nSubject: %s Digest\n\nTopics:\n" 844 "Date: %s\nFrom: %s\nSubject: %s Digest\n\nTopics:\n"
@@ -844,7 +846,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
844 (when (not (eq in-state 'end)) 846 (when (not (eq in-state 'end))
845 (setq state (list 'middle)))) 847 (setq state (list 'middle))))
846 (save-excursion 848 (save-excursion
847 (set-buffer (get-buffer "*gnus-uu-body*")) 849 (set-buffer "*gnus-uu-body*")
848 (goto-char (setq beg (point-max))) 850 (goto-char (setq beg (point-max)))
849 (save-excursion 851 (save-excursion
850 (save-restriction 852 (save-restriction
@@ -858,10 +860,10 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
858 (re-search-forward "\n\n") 860 (re-search-forward "\n\n")
859 ;; Quote all 30-dash lines. 861 ;; Quote all 30-dash lines.
860 (save-excursion 862 (save-excursion
861 (while (re-search-forward delim nil t) 863 (while (re-search-forward "^-" nil t)
862 (beginning-of-line) 864 (beginning-of-line)
863 (delete-char 1) 865 (delete-char 1)
864 (insert " "))) 866 (insert "- ")))
865 (setq body (buffer-substring (1- (point)) (point-max))) 867 (setq body (buffer-substring (1- (point)) (point-max)))
866 (narrow-to-region (point-min) (point)) 868 (narrow-to-region (point-min) (point))
867 (if (not (setq headers gnus-uu-digest-headers)) 869 (if (not (setq headers gnus-uu-digest-headers))
@@ -886,16 +888,16 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
886 (when (re-search-forward "^Subject: \\(.*\\)$" nil t) 888 (when (re-search-forward "^Subject: \\(.*\\)$" nil t)
887 (setq subj (buffer-substring (match-beginning 1) (match-end 1))) 889 (setq subj (buffer-substring (match-beginning 1) (match-end 1)))
888 (save-excursion 890 (save-excursion
889 (set-buffer (get-buffer "*gnus-uu-pre*")) 891 (set-buffer "*gnus-uu-pre*")
890 (insert (format " %s\n" subj))))) 892 (insert (format " %s\n" subj)))))
891 (when (or (eq in-state 'last) 893 (when (or (eq in-state 'last)
892 (eq in-state 'first-and-last)) 894 (eq in-state 'first-and-last))
893 (save-excursion 895 (save-excursion
894 (set-buffer (get-buffer "*gnus-uu-pre*")) 896 (set-buffer "*gnus-uu-pre*")
895 (insert (format "\n\n%s\n\n" (make-string 70 ?-))) 897 (insert (format "\n\n%s\n\n" (make-string 70 ?-)))
896 (gnus-write-buffer gnus-uu-saved-article-name)) 898 (gnus-write-buffer gnus-uu-saved-article-name))
897 (save-excursion 899 (save-excursion
898 (set-buffer (get-buffer "*gnus-uu-body*")) 900 (set-buffer "*gnus-uu-body*")
899 (goto-char (point-max)) 901 (goto-char (point-max))
900 (insert 902 (insert
901 (concat (setq end-string (format "End of %s Digest" name)) 903 (concat (setq end-string (format "End of %s Digest" name))
@@ -903,8 +905,8 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
903 (insert (concat (make-string (length end-string) ?*) "\n")) 905 (insert (concat (make-string (length end-string) ?*) "\n"))
904 (write-region 906 (write-region
905 (point-min) (point-max) gnus-uu-saved-article-name t)) 907 (point-min) (point-max) gnus-uu-saved-article-name t))
906 (kill-buffer (get-buffer "*gnus-uu-pre*")) 908 (gnus-kill-buffer "*gnus-uu-pre*")
907 (kill-buffer (get-buffer "*gnus-uu-body*")) 909 (gnus-kill-buffer "*gnus-uu-body*")
908 (push 'end state)) 910 (push 'end state))
909 (if (memq 'begin state) 911 (if (memq 'begin state)
910 (cons gnus-uu-saved-article-name state) 912 (cons gnus-uu-saved-article-name state)
@@ -912,11 +914,11 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
912 914
913;; Binhex treatment - not very advanced. 915;; Binhex treatment - not very advanced.
914 916
915(defconst gnus-uu-binhex-body-line 917(defvar gnus-uu-binhex-body-line
916 "^[^:]...............................................................$") 918 "^[^:]...............................................................$")
917(defconst gnus-uu-binhex-begin-line 919(defvar gnus-uu-binhex-begin-line
918 "^:...............................................................$") 920 "^:...............................................................$")
919(defconst gnus-uu-binhex-end-line 921(defvar gnus-uu-binhex-end-line
920 ":$") 922 ":$")
921 923
922(defun gnus-uu-binhex-article (buffer in-state) 924(defun gnus-uu-binhex-article (buffer in-state)
@@ -969,7 +971,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
969 (if (not (re-search-forward gnus-uu-postscript-end-string nil t)) 971 (if (not (re-search-forward gnus-uu-postscript-end-string nil t))
970 (setq state (list 'wrong-type)) 972 (setq state (list 'wrong-type))
971 (setq end-char (point)) 973 (setq end-char (point))
972 (set-buffer (get-buffer-create gnus-uu-output-buffer-name)) 974 (set-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name))
973 (insert-buffer-substring process-buffer start-char end-char) 975 (insert-buffer-substring process-buffer start-char end-char)
974 (setq file-name (concat gnus-uu-work-dir 976 (setq file-name (concat gnus-uu-work-dir
975 (cdr gnus-article-current) ".ps")) 977 (cdr gnus-article-current) ".ps"))
@@ -1019,45 +1021,36 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
1019 1021
1020(defun gnus-uu-reginize-string (string) 1022(defun gnus-uu-reginize-string (string)
1021 ;; Takes a string and puts a \ in front of every special character; 1023 ;; Takes a string and puts a \ in front of every special character;
1022 ;; ignores any leading "version numbers" thingies that they use in 1024 ;; replaces the last thing that looks like "2/3" with "[0-9]+/3"
1023 ;; the comp.binaries groups, and either replaces anything that looks 1025 ;; or, if it can't find something like that, tries "2 of 3", then
1024 ;; like "2/3" with "[0-9]+/[0-9]+" or, if it can't find something 1026 ;; finally just replaces the next to last number with "[0-9]+".
1025 ;; like that, replaces the last two numbers with "[0-9]+". This, in 1027 (save-excursion
1026 ;; my experience, should get most postings of a series. 1028 (set-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name))
1027 (let ((count 2) 1029 (buffer-disable-undo (current-buffer))
1028 (vernum "v[0-9]+[a-z][0-9]+:") 1030 (erase-buffer)
1029 beg) 1031 (insert (regexp-quote string))
1030 (save-excursion
1031 (set-buffer (get-buffer-create gnus-uu-output-buffer-name))
1032 (buffer-disable-undo (current-buffer))
1033 (erase-buffer)
1034 (insert (regexp-quote string))
1035 (setq beg 1)
1036 1032
1037 (setq case-fold-search nil) 1033 (setq case-fold-search nil)
1038 (goto-char (point-min))
1039 (when (looking-at vernum)
1040 (replace-match vernum t t)
1041 (setq beg (length vernum)))
1042 1034
1043 (goto-char beg) 1035 (end-of-line)
1044 (if (re-search-forward "[ \t]*[0-9]+/[0-9]+" nil t) 1036 (if (re-search-backward "\\([^0-9]\\)[0-9]+/\\([0-9]+\\)" nil t)
1045 (replace-match " [0-9]+/[0-9]+") 1037 (replace-match "\\1[0-9]+/\\2")
1046 1038
1047 (goto-char beg) 1039 (end-of-line)
1048 (if (re-search-forward "[0-9]+[ \t]*of[ \t]*[0-9]+" nil t) 1040 (if (re-search-backward "\\([^0-9]\\)[0-9]+[ \t]*of[ \t]*\\([0-9]+\\)"
1049 (replace-match "[0-9]+ of [0-9]+") 1041 nil t)
1042 (replace-match "\\1[0-9]+ of \\2")
1050 1043
1051 (end-of-line) 1044 (end-of-line)
1052 (if (re-search-backward "\\([^0-9]\\)[0-9]+\\([^0-9]+\\)[0-9]+" 1045 (if (re-search-backward "\\([^0-9]\\)[0-9]+\\([^0-9]+\\)[0-9]+"
1053 nil t) 1046 nil t)
1054 (replace-match "\\1[0-9]+\\2[0-9]+" t nil nil nil)))) 1047 (replace-match "\\1[0-9]+\\2[0-9]+" t nil nil nil))))
1055 1048
1056 (goto-char beg) 1049 (goto-char 1)
1057 (while (re-search-forward "[ \t]+" nil t) 1050 (while (re-search-forward "[ \t]+" nil t)
1058 (replace-match "[ \t]*" t t)) 1051 (replace-match "[ \t]+" t t))
1059 1052
1060 (buffer-substring 1 (point-max))))) 1053 (buffer-substring 1 (point-max))))
1061 1054
1062(defun gnus-uu-get-list-of-articles (n) 1055(defun gnus-uu-get-list-of-articles (n)
1063 ;; If N is non-nil, the article numbers of the N next articles 1056 ;; If N is non-nil, the article numbers of the N next articles
@@ -1097,8 +1090,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
1097 (gnus-uu-reginize-string (gnus-summary-article-subject)))) 1090 (gnus-uu-reginize-string (gnus-summary-article-subject))))
1098 list-of-subjects) 1091 list-of-subjects)
1099 (save-excursion 1092 (save-excursion
1100 (if (not subject) 1093 (when subject
1101 ()
1102 ;; Collect all subjects matching subject. 1094 ;; Collect all subjects matching subject.
1103 (let ((case-fold-search t) 1095 (let ((case-fold-search t)
1104 (data gnus-newsgroup-data) 1096 (data gnus-newsgroup-data)
@@ -1133,7 +1125,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
1133 (let ((out-list string-list) 1125 (let ((out-list string-list)
1134 string) 1126 string)
1135 (save-excursion 1127 (save-excursion
1136 (set-buffer (get-buffer-create gnus-uu-output-buffer-name)) 1128 (set-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name))
1137 (buffer-disable-undo (current-buffer)) 1129 (buffer-disable-undo (current-buffer))
1138 (while string-list 1130 (while string-list
1139 (erase-buffer) 1131 (erase-buffer)
@@ -1208,6 +1200,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
1208(defun gnus-uu-grab-articles (articles process-function 1200(defun gnus-uu-grab-articles (articles process-function
1209 &optional sloppy limit no-errors) 1201 &optional sloppy limit no-errors)
1210 (let ((state 'first) 1202 (let ((state 'first)
1203 (gnus-asynchronous nil)
1211 has-been-begin article result-file result-files process-state 1204 has-been-begin article result-file result-files process-state
1212 gnus-summary-display-article-function 1205 gnus-summary-display-article-function
1213 gnus-article-display-hook gnus-article-prepare-hook 1206 gnus-article-display-hook gnus-article-prepare-hook
@@ -1219,119 +1212,121 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
1219 (not (memq 'end process-state)))) 1212 (not (memq 'end process-state))))
1220 1213
1221 (setq article (pop articles)) 1214 (setq article (pop articles))
1222 (push article article-series) 1215 (when (vectorp (gnus-summary-article-header article))
1223 1216 (push article article-series)
1224 (unless articles
1225 (if (eq state 'first)
1226 (setq state 'first-and-last)
1227 (setq state 'last)))
1228 1217
1229 (let ((part (gnus-uu-part-number article))) 1218 (unless articles
1230 (gnus-message 6 "Getting article %d%s..." 1219 (if (eq state 'first)
1231 article (if (string= part "") "" (concat ", " part)))) 1220 (setq state 'first-and-last)
1232 (gnus-summary-display-article article) 1221 (setq state 'last)))
1233 1222
1234 ;; Push the article to the processing function. 1223 (let ((part (gnus-uu-part-number article)))
1235 (save-excursion 1224 (gnus-message 6 "Getting article %d%s..."
1236 (set-buffer gnus-original-article-buffer) 1225 article (if (string= part "") "" (concat ", " part))))
1237 (let ((buffer-read-only nil)) 1226 (gnus-summary-display-article article)
1238 (save-excursion
1239 (set-buffer gnus-summary-buffer)
1240 (setq process-state
1241 (funcall process-function
1242 gnus-original-article-buffer state)))))
1243
1244 (gnus-summary-remove-process-mark article)
1245
1246 ;; If this is the beginning of a decoded file, we push it
1247 ;; on to a list.
1248 (when (or (memq 'begin process-state)
1249 (and (or (eq state 'first)
1250 (eq state 'first-and-last))
1251 (memq 'ok process-state)))
1252 (when has-been-begin
1253 ;; If there is a `result-file' here, that means that the
1254 ;; file was unsuccessfully decoded, so we delete it.
1255 (when (and result-file
1256 (file-exists-p result-file)
1257 (not gnus-uu-be-dangerous)
1258 (or (eq gnus-uu-be-dangerous t)
1259 (gnus-y-or-n-p
1260 (format "Delete unsuccessfully decoded file %s"
1261 result-file))))
1262 (delete-file result-file)))
1263 (when (memq 'begin process-state)
1264 (setq result-file (car process-state)))
1265 (setq has-been-begin t))
1266
1267 ;; Check whether we have decoded one complete file.
1268 (when (memq 'end process-state)
1269 (setq article-series nil)
1270 (setq has-been-begin nil)
1271 (if (stringp result-file)
1272 (setq files (list result-file))
1273 (setq files result-file))
1274 (setq result-file (car files))
1275 (while files
1276 (push (list (cons 'name (pop files))
1277 (cons 'article article))
1278 result-files))
1279 ;; Allow user-defined functions to be run on this file.
1280 (when gnus-uu-grabbed-file-functions
1281 (let ((funcs gnus-uu-grabbed-file-functions))
1282 (unless (listp funcs)
1283 (setq funcs (list funcs)))
1284 (while funcs
1285 (funcall (pop funcs) result-file))))
1286 (setq result-file nil)
1287 ;; Check whether we have decoded enough articles.
1288 (and limit (= (length result-files) limit)
1289 (setq articles nil)))
1290
1291 ;; If this is the last article to be decoded, and
1292 ;; we still haven't reached the end, then we delete
1293 ;; the partially decoded file.
1294 (and (or (eq state 'last) (eq state 'first-and-last))
1295 (not (memq 'end process-state))
1296 result-file
1297 (file-exists-p result-file)
1298 (not gnus-uu-be-dangerous)
1299 (or (eq gnus-uu-be-dangerous t)
1300 (gnus-y-or-n-p (format "Delete incomplete file %s? " result-file)))
1301 (delete-file result-file))
1302
1303 ;; If this was a file of the wrong sort, then
1304 (when (and (or (memq 'wrong-type process-state)
1305 (memq 'error process-state))
1306 gnus-uu-unmark-articles-not-decoded)
1307 (gnus-summary-tick-article article t))
1308
1309 ;; Set the new series state.
1310 (if (and (not has-been-begin)
1311 (not sloppy)
1312 (or (memq 'end process-state)
1313 (memq 'middle process-state)))
1314 (progn
1315 (setq process-state (list 'error))
1316 (gnus-message 2 "No begin part at the beginning")
1317 (sleep-for 2))
1318 (setq state 'middle)))
1319 1227
1320 ;; When there are no result-files, then something must be wrong. 1228 ;; Push the article to the processing function.
1321 (if result-files 1229 (save-excursion
1322 (message "") 1230 (set-buffer gnus-original-article-buffer)
1323 (cond 1231 (let ((buffer-read-only nil))
1324 ((not has-been-begin) 1232 (save-excursion
1325 (gnus-message 2 "Wrong type file")) 1233 (set-buffer gnus-summary-buffer)
1326 ((memq 'error process-state) 1234 (setq process-state
1327 (gnus-message 2 "An error occurred during decoding")) 1235 (funcall process-function
1328 ((not (or (memq 'ok process-state) 1236 gnus-original-article-buffer state)))))
1329 (memq 'end process-state))) 1237
1330 (gnus-message 2 "End of articles reached before end of file"))) 1238 (gnus-summary-remove-process-mark article)
1331 ;; Make unsuccessfully decoded articles unread. 1239
1332 (when gnus-uu-unmark-articles-not-decoded 1240 ;; If this is the beginning of a decoded file, we push it
1333 (while article-series 1241 ;; on to a list.
1334 (gnus-summary-tick-article (pop article-series) t)))) 1242 (when (or (memq 'begin process-state)
1243 (and (or (eq state 'first)
1244 (eq state 'first-and-last))
1245 (memq 'ok process-state)))
1246 (when has-been-begin
1247 ;; If there is a `result-file' here, that means that the
1248 ;; file was unsuccessfully decoded, so we delete it.
1249 (when (and result-file
1250 (file-exists-p result-file)
1251 (not gnus-uu-be-dangerous)
1252 (or (eq gnus-uu-be-dangerous t)
1253 (gnus-y-or-n-p
1254 (format "Delete unsuccessfully decoded file %s"
1255 result-file))))
1256 (delete-file result-file)))
1257 (when (memq 'begin process-state)
1258 (setq result-file (car process-state)))
1259 (setq has-been-begin t))
1260
1261 ;; Check whether we have decoded one complete file.
1262 (when (memq 'end process-state)
1263 (setq article-series nil)
1264 (setq has-been-begin nil)
1265 (if (stringp result-file)
1266 (setq files (list result-file))
1267 (setq files result-file))
1268 (setq result-file (car files))
1269 (while files
1270 (push (list (cons 'name (pop files))
1271 (cons 'article article))
1272 result-files))
1273 ;; Allow user-defined functions to be run on this file.
1274 (when gnus-uu-grabbed-file-functions
1275 (let ((funcs gnus-uu-grabbed-file-functions))
1276 (unless (listp funcs)
1277 (setq funcs (list funcs)))
1278 (while funcs
1279 (funcall (pop funcs) result-file))))
1280 (setq result-file nil)
1281 ;; Check whether we have decoded enough articles.
1282 (and limit (= (length result-files) limit)
1283 (setq articles nil)))
1284
1285 ;; If this is the last article to be decoded, and
1286 ;; we still haven't reached the end, then we delete
1287 ;; the partially decoded file.
1288 (and (or (eq state 'last) (eq state 'first-and-last))
1289 (not (memq 'end process-state))
1290 result-file
1291 (file-exists-p result-file)
1292 (not gnus-uu-be-dangerous)
1293 (or (eq gnus-uu-be-dangerous t)
1294 (gnus-y-or-n-p
1295 (format "Delete incomplete file %s? " result-file)))
1296 (delete-file result-file))
1297
1298 ;; If this was a file of the wrong sort, then
1299 (when (and (or (memq 'wrong-type process-state)
1300 (memq 'error process-state))
1301 gnus-uu-unmark-articles-not-decoded)
1302 (gnus-summary-tick-article article t))
1303
1304 ;; Set the new series state.
1305 (if (and (not has-been-begin)
1306 (not sloppy)
1307 (or (memq 'end process-state)
1308 (memq 'middle process-state)))
1309 (progn
1310 (setq process-state (list 'error))
1311 (gnus-message 2 "No begin part at the beginning")
1312 (sleep-for 2))
1313 (setq state 'middle)))
1314
1315 ;; When there are no result-files, then something must be wrong.
1316 (if result-files
1317 (message "")
1318 (cond
1319 ((not has-been-begin)
1320 (gnus-message 2 "Wrong type file"))
1321 ((memq 'error process-state)
1322 (gnus-message 2 "An error occurred during decoding"))
1323 ((not (or (memq 'ok process-state)
1324 (memq 'end process-state)))
1325 (gnus-message 2 "End of articles reached before end of file")))
1326 ;; Make unsuccessfully decoded articles unread.
1327 (when gnus-uu-unmark-articles-not-decoded
1328 (while article-series
1329 (gnus-summary-tick-article (pop article-series) t)))))
1335 1330
1336 result-files)) 1331 result-files))
1337 1332
@@ -1355,11 +1350,18 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
1355 1350
1356(defun gnus-uu-part-number (article) 1351(defun gnus-uu-part-number (article)
1357 (let* ((header (gnus-summary-article-header article)) 1352 (let* ((header (gnus-summary-article-header article))
1358 (subject (and header (mail-header-subject header)))) 1353 (subject (and header (mail-header-subject header)))
1359 (if (and subject 1354 (part nil))
1360 (string-match "[0-9]+ */[0-9]+\\|[0-9]+ * of *[0-9]+" subject)) 1355 (if subject
1361 (match-string 0 subject) 1356 (while (string-match "[0-9]+/[0-9]+\\|[0-9]+[ \t]+of[ \t]+[0-9]+"
1362 ""))) 1357 subject)
1358 (setq part (match-string 0 subject))
1359 (setq subject (substring subject (match-end 0)))))
1360 (or part
1361 (while (string-match "\\([0-9]+\\)[^0-9]+\\([0-9]+\\)" subject)
1362 (setq part (match-string 0 subject))
1363 (setq subject (substring subject (match-end 0)))))
1364 (or part "")))
1363 1365
1364(defun gnus-uu-uudecode-sentinel (process event) 1366(defun gnus-uu-uudecode-sentinel (process event)
1365 (delete-process (get-process process))) 1367 (delete-process (get-process process)))
@@ -1417,7 +1419,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
1417 (setq gnus-uu-uudecode-process 1419 (setq gnus-uu-uudecode-process
1418 (start-process 1420 (start-process
1419 "*uudecode*" 1421 "*uudecode*"
1420 (get-buffer-create gnus-uu-output-buffer-name) 1422 (gnus-get-buffer-create gnus-uu-output-buffer-name)
1421 shell-file-name shell-command-switch 1423 shell-file-name shell-command-switch
1422 (format "cd %s %s uudecode" gnus-uu-work-dir 1424 (format "cd %s %s uudecode" gnus-uu-work-dir
1423 gnus-shell-command-separator)))) 1425 gnus-shell-command-separator))))
@@ -1440,6 +1442,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
1440 ;; Try to correct mishandled uucode. 1442 ;; Try to correct mishandled uucode.
1441 (when gnus-uu-correct-stripped-uucode 1443 (when gnus-uu-correct-stripped-uucode
1442 (gnus-uu-check-correct-stripped-uucode start-char (point))) 1444 (gnus-uu-check-correct-stripped-uucode start-char (point)))
1445 (gnus-run-hooks 'gnus-uu-pre-uudecode-hook)
1443 1446
1444 ;; Send the text to the process. 1447 ;; Send the text to the process.
1445 (condition-case nil 1448 (condition-case nil
@@ -1482,7 +1485,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
1482 (setq start-char (point)) 1485 (setq start-char (point))
1483 (call-process-region 1486 (call-process-region
1484 start-char (point-max) shell-file-name nil 1487 start-char (point-max) shell-file-name nil
1485 (get-buffer-create gnus-uu-output-buffer-name) nil 1488 (gnus-get-buffer-create gnus-uu-output-buffer-name) nil
1486 shell-command-switch 1489 shell-command-switch
1487 (concat "cd " gnus-uu-work-dir " " 1490 (concat "cd " gnus-uu-work-dir " "
1488 gnus-shell-command-separator " sh")))) 1491 gnus-shell-command-separator " sh"))))
@@ -1545,13 +1548,13 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
1545 (setq command (format "cd %s ; %s" dir (gnus-uu-command action file-path))) 1548 (setq command (format "cd %s ; %s" dir (gnus-uu-command action file-path)))
1546 1549
1547 (save-excursion 1550 (save-excursion
1548 (set-buffer (get-buffer-create gnus-uu-output-buffer-name)) 1551 (set-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name))
1549 (erase-buffer)) 1552 (erase-buffer))
1550 1553
1551 (gnus-message 5 "Unpacking: %s..." (gnus-uu-command action file-path)) 1554 (gnus-message 5 "Unpacking: %s..." (gnus-uu-command action file-path))
1552 1555
1553 (if (= 0 (call-process shell-file-name nil 1556 (if (= 0 (call-process shell-file-name nil
1554 (get-buffer-create gnus-uu-output-buffer-name) 1557 (gnus-get-buffer-create gnus-uu-output-buffer-name)
1555 nil shell-command-switch command)) 1558 nil shell-command-switch command))
1556 (message "") 1559 (message "")
1557 (gnus-message 2 "Error during unpacking of archive") 1560 (gnus-message 2 "Error during unpacking of archive")
@@ -1696,7 +1699,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
1696(defun gnus-quote-arg-for-sh-or-csh (arg) 1699(defun gnus-quote-arg-for-sh-or-csh (arg)
1697 (let ((pos 0) new-pos accum) 1700 (let ((pos 0) new-pos accum)
1698 ;; *** bug: we don't handle newline characters properly 1701 ;; *** bug: we don't handle newline characters properly
1699 (while (setq new-pos (string-match "[!`\"$\\& \t{}]" arg pos)) 1702 (while (setq new-pos (string-match "[;!`\"$\\& \t{}]" arg pos))
1700 (push (substring arg pos new-pos) accum) 1703 (push (substring arg pos new-pos) accum)
1701 (push "\\" accum) 1704 (push "\\" accum)
1702 (push (list (aref arg new-pos)) accum) 1705 (push (list (aref arg new-pos)) accum)
@@ -1839,7 +1842,8 @@ The user will be asked for a file name."
1839 1842
1840;; Encodes with base64 and adds MIME headers 1843;; Encodes with base64 and adds MIME headers
1841(defun gnus-uu-post-encode-mime (path file-name) 1844(defun gnus-uu-post-encode-mime (path file-name)
1842 (when (gnus-uu-post-encode-file "mmencode" path file-name) 1845 (when (zerop (call-process shell-file-name nil t nil shell-command-switch
1846 (format "%s %s -o %s" "mmencode" path file-name)))
1843 (gnus-uu-post-make-mime file-name "base64") 1847 (gnus-uu-post-make-mime file-name "base64")
1844 t)) 1848 t))
1845 1849
@@ -1897,8 +1901,10 @@ If no file has been included, the user will be asked for a file."
1897 (goto-char (point-max)) 1901 (goto-char (point-max))
1898 (insert (format "\n%s\n" gnus-uu-post-binary-separator)) 1902 (insert (format "\n%s\n" gnus-uu-post-binary-separator))
1899 1903
1904 ;; #### Unix-specific?
1900 (when (string-match "^~/" file-path) 1905 (when (string-match "^~/" file-path)
1901 (setq file-path (concat "$HOME" (substring file-path 1)))) 1906 (setq file-path (concat "$HOME" (substring file-path 1))))
1907 ;; #### Unix-specific?
1902 (if (string-match "/[^/]*$" file-path) 1908 (if (string-match "/[^/]*$" file-path)
1903 (setq file-name (substring file-path (1+ (match-beginning 0)))) 1909 (setq file-name (substring file-path (1+ (match-beginning 0))))
1904 (setq file-name file-path)) 1910 (setq file-name file-path))
@@ -1906,7 +1912,7 @@ If no file has been included, the user will be asked for a file."
1906 (unwind-protect 1912 (unwind-protect
1907 (if (save-excursion 1913 (if (save-excursion
1908 (set-buffer (setq uubuf 1914 (set-buffer (setq uubuf
1909 (get-buffer-create uuencode-buffer-name))) 1915 (gnus-get-buffer-create uuencode-buffer-name)))
1910 (erase-buffer) 1916 (erase-buffer)
1911 (funcall gnus-uu-post-encode-method file-path file-name)) 1917 (funcall gnus-uu-post-encode-method file-path file-name))
1912 (insert-buffer-substring uubuf) 1918 (insert-buffer-substring uubuf)
@@ -1921,7 +1927,7 @@ If no file has been included, the user will be asked for a file."
1921 (top-string "[ cut here %s (%s %d/%d) %s gnus-uu ]") 1927 (top-string "[ cut here %s (%s %d/%d) %s gnus-uu ]")
1922 (separator (concat mail-header-separator "\n\n")) 1928 (separator (concat mail-header-separator "\n\n"))
1923 uubuf length parts header i end beg 1929 uubuf length parts header i end beg
1924 beg-line minlen buf post-buf whole-len beg-binary end-binary) 1930 beg-line minlen post-buf whole-len beg-binary end-binary)
1925 1931
1926 (setq post-buf (current-buffer)) 1932 (setq post-buf (current-buffer))
1927 1933
@@ -1939,7 +1945,7 @@ If no file has been included, the user will be asked for a file."
1939 (setq end-binary (point-max)) 1945 (setq end-binary (point-max))
1940 1946
1941 (save-excursion 1947 (save-excursion
1942 (set-buffer (setq uubuf (get-buffer-create encoded-buffer-name))) 1948 (set-buffer (setq uubuf (gnus-get-buffer-create encoded-buffer-name)))
1943 (erase-buffer) 1949 (erase-buffer)
1944 (insert-buffer-substring post-buf beg-binary end-binary) 1950 (insert-buffer-substring post-buf beg-binary end-binary)
1945 (goto-char (point-min)) 1951 (goto-char (point-min))
@@ -1971,7 +1977,7 @@ If no file has been included, the user will be asked for a file."
1971 (setq i 1) 1977 (setq i 1)
1972 (setq beg 1) 1978 (setq beg 1)
1973 (while (not (> i parts)) 1979 (while (not (> i parts))
1974 (set-buffer (get-buffer-create send-buffer-name)) 1980 (set-buffer (gnus-get-buffer-create send-buffer-name))
1975 (erase-buffer) 1981 (erase-buffer)
1976 (insert header) 1982 (insert header)
1977 (when (and threaded gnus-uu-post-message-id) 1983 (when (and threaded gnus-uu-post-message-id)
diff --git a/lisp/gnus/gnus-vm.el b/lisp/gnus/gnus-vm.el
index 8e83dbea95a..bbefaaca5f9 100644
--- a/lisp/gnus/gnus-vm.el
+++ b/lisp/gnus/gnus-vm.el
@@ -1,5 +1,5 @@
1;;; gnus-vm.el --- vm interface for Gnus 1;;; gnus-vm.el --- vm interface for Gnus
2;; Copyright (C) 1994,95,96,97 Free Software Foundation, Inc. 2;; Copyright (C) 1994,95,96,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Per Persson <pp@gnu.ai.mit.edu> 4;; Author: Per Persson <pp@gnu.ai.mit.edu>
5;; Keywords: news, mail 5;; Keywords: news, mail
@@ -88,12 +88,10 @@ save those articles instead."
88(defun gnus-summary-save-in-vm (&optional folder) 88(defun gnus-summary-save-in-vm (&optional folder)
89 (interactive) 89 (interactive)
90 (setq folder 90 (setq folder
91 (cond ((eq folder 'default) default-name) 91 (gnus-read-save-file-name
92 (folder folder) 92 "Save %s in VM folder:" folder
93 (t (gnus-read-save-file-name 93 gnus-mail-save-name gnus-newsgroup-name
94 "Save %s in VM folder:" folder 94 gnus-current-headers 'gnus-newsgroup-last-mail))
95 gnus-mail-save-name gnus-newsgroup-name
96 gnus-current-headers 'gnus-newsgroup-last-mail))))
97 (gnus-eval-in-buffer-window gnus-original-article-buffer 95 (gnus-eval-in-buffer-window gnus-original-article-buffer
98 (save-excursion 96 (save-excursion
99 (save-restriction 97 (save-restriction
diff --git a/lisp/gnus/gnus-win.el b/lisp/gnus/gnus-win.el
index 59a80e984f1..ea0d65ddd11 100644
--- a/lisp/gnus/gnus-win.el
+++ b/lisp/gnus/gnus-win.el
@@ -1,7 +1,7 @@
1;;; gnus-win.el --- window configuration functions for Gnus 1;;; gnus-win.el --- window configuration functions for Gnus
2;; Copyright (C) 1996,97 Free Software Foundation, Inc. 2;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: news 5;; Keywords: news
6 6
7;; This file is part of GNU Emacs. 7;; This file is part of GNU Emacs.
@@ -27,6 +27,8 @@
27 27
28(eval-when-compile (require 'cl)) 28(eval-when-compile (require 'cl))
29 29
30(eval-when-compile (require 'cl))
31
30(require 'gnus) 32(require 'gnus)
31 33
32(defgroup gnus-windows nil 34(defgroup gnus-windows nil
@@ -137,9 +139,6 @@
137 (vertical 1.0 139 (vertical 1.0
138 (article 0.5) 140 (article 0.5)
139 (message 1.0 point))) 141 (message 1.0 point)))
140 (draft
141 (vertical 1.0
142 (draft 1.0 point)))
143 (pipe 142 (pipe
144 (vertical 1.0 143 (vertical 1.0
145 (summary 0.25 point) 144 (summary 0.25 point)
@@ -157,6 +156,13 @@
157 (vertical 1.0 156 (vertical 1.0
158 (summary 0.5 point) 157 (summary 0.5 point)
159 ("*Score Words*" 1.0))) 158 ("*Score Words*" 1.0)))
159 (split-trace
160 (vertical 1.0
161 (summary 0.5 point)
162 ("*Split Trace*" 1.0)))
163 (category
164 (vertical 1.0
165 (category 1.0)))
160 (compose-bounce 166 (compose-bounce
161 (vertical 1.0 167 (vertical 1.0
162 (article 0.5) 168 (article 0.5)
@@ -182,10 +188,12 @@ See the Gnus manual for an explanation of the syntax used.")
182 (mail . gnus-message-buffer) 188 (mail . gnus-message-buffer)
183 (post-news . gnus-message-buffer) 189 (post-news . gnus-message-buffer)
184 (faq . gnus-faq-buffer) 190 (faq . gnus-faq-buffer)
185 (picons . "*Picons*") 191 (picons . gnus-picons-buffer-name)
186 (tree . gnus-tree-buffer) 192 (tree . gnus-tree-buffer)
187 (score-trace . "*Score Trace*") 193 (score-trace . "*Score Trace*")
194 (split-trace . "*Split Trace*")
188 (info . gnus-info-buffer) 195 (info . gnus-info-buffer)
196 (category . gnus-category-buffer)
189 (article-copy . gnus-article-copy) 197 (article-copy . gnus-article-copy)
190 (draft . gnus-draft-buffer)) 198 (draft . gnus-draft-buffer))
191 "Mapping from short symbols to buffer names or buffer variables.") 199 "Mapping from short symbols to buffer names or buffer variables.")
@@ -196,6 +204,7 @@ See the Gnus manual for an explanation of the syntax used.")
196 "The most recently set window configuration.") 204 "The most recently set window configuration.")
197 205
198(defvar gnus-created-frames nil) 206(defvar gnus-created-frames nil)
207(defvar gnus-window-frame-focus nil)
199 208
200(defun gnus-kill-gnus-frames () 209(defun gnus-kill-gnus-frames ()
201 "Kill all frames Gnus has created." 210 "Kill all frames Gnus has created."
@@ -266,6 +275,16 @@ See the Gnus manual for an explanation of the syntax used.")
266 275
267(defvar gnus-frame-list nil) 276(defvar gnus-frame-list nil)
268 277
278(defun gnus-window-to-buffer-helper (obj)
279 (cond ((not (symbolp obj))
280 obj)
281 ((boundp obj)
282 (symbol-value obj))
283 ((fboundp obj)
284 (funcall obj))
285 (t
286 nil)))
287
269(defun gnus-configure-frame (split &optional window) 288(defun gnus-configure-frame (split &optional window)
270 "Split WINDOW according to SPLIT." 289 "Split WINDOW according to SPLIT."
271 (unless window 290 (unless window
@@ -299,15 +318,13 @@ See the Gnus manual for an explanation of the syntax used.")
299 ;; This is a buffer to be selected. 318 ;; This is a buffer to be selected.
300 ((not (memq type '(frame horizontal vertical))) 319 ((not (memq type '(frame horizontal vertical)))
301 (let ((buffer (cond ((stringp type) type) 320 (let ((buffer (cond ((stringp type) type)
302 (t (cdr (assq type gnus-window-to-buffer))))) 321 (t (cdr (assq type gnus-window-to-buffer))))))
303 buf)
304 (unless buffer 322 (unless buffer
305 (error "Illegal buffer type: %s" type)) 323 (error "Illegal buffer type: %s" type))
306 (unless (setq buf (get-buffer (if (symbolp buffer) 324 (switch-to-buffer (gnus-get-buffer-create
307 (symbol-value buffer) buffer))) 325 (gnus-window-to-buffer-helper buffer)))
308 (setq buf (get-buffer-create (if (symbolp buffer) 326 (when (memq 'frame-focus split)
309 (symbol-value buffer) buffer)))) 327 (setq gnus-window-frame-focus window))
310 (switch-to-buffer buf)
311 ;; We return the window if it has the `point' spec. 328 ;; We return the window if it has the `point' spec.
312 (and (memq 'point split) window))) 329 (and (memq 'point split) window)))
313 ;; This is a frame split. 330 ;; This is a frame split.
@@ -431,20 +448,14 @@ See the Gnus manual for an explanation of the syntax used.")
431 (select-frame frame))) 448 (select-frame frame)))
432 449
433 (switch-to-buffer nntp-server-buffer) 450 (switch-to-buffer nntp-server-buffer)
434 (gnus-configure-frame split (get-buffer-window (current-buffer)))))) 451 (let (gnus-window-frame-focus)
452 (gnus-configure-frame split (get-buffer-window (current-buffer)))
453 (when gnus-window-frame-focus
454 (select-frame (window-frame gnus-window-frame-focus)))))))
435 455
436(defun gnus-delete-windows-in-gnusey-frames () 456(defun gnus-delete-windows-in-gnusey-frames ()
437 "Do a `delete-other-windows' in all frames that have Gnus windows." 457 "Do a `delete-other-windows' in all frames that have Gnus windows."
438 (let ((buffers 458 (let ((buffers (gnus-buffers)))
439 (mapcar
440 (lambda (elem)
441 (if (symbolp (cdr elem))
442 (when (and (boundp (cdr elem))
443 (symbol-value (cdr elem)))
444 (get-buffer (symbol-value (cdr elem))))
445 (when (cdr elem)
446 (get-buffer (cdr elem)))))
447 gnus-window-to-buffer)))
448 (mapcar 459 (mapcar
449 (lambda (frame) 460 (lambda (frame)
450 (unless (eq (cdr (assq 'minibuffer 461 (unless (eq (cdr (assq 'minibuffer
@@ -492,12 +503,9 @@ should have point."
492 (t (cdr (assq type gnus-window-to-buffer))))) 503 (t (cdr (assq type gnus-window-to-buffer)))))
493 (unless buffer 504 (unless buffer
494 (error "Illegal buffer type: %s" type)) 505 (error "Illegal buffer type: %s" type))
495 (when (setq buf (get-buffer (if (symbolp buffer) 506 (if (and (setq buf (get-buffer (gnus-window-to-buffer-helper buffer)))
496 (symbol-value buffer) 507 (setq win (get-buffer-window buf t)))
497 buffer))) 508 (if (memq 'point split)
498 (setq win (get-buffer-window buf t)))
499 (if win
500 (when (memq 'point split)
501 (setq all-visible win)) 509 (setq all-visible win))
502 (setq all-visible nil))) 510 (setq all-visible nil)))
503 (t 511 (t
@@ -511,42 +519,22 @@ should have point."
511 (nth 1 (window-edges window))) 519 (nth 1 (window-edges window)))
512 520
513(defun gnus-remove-some-windows () 521(defun gnus-remove-some-windows ()
514 (let ((buffers gnus-window-to-buffer) 522 (let ((buffers (gnus-buffers))
515 buf bufs lowest-buf lowest) 523 buf bufs lowest-buf lowest)
516 (save-excursion 524 (save-excursion
517 ;; Remove windows on all known Gnus buffers. 525 ;; Remove windows on all known Gnus buffers.
518 (while buffers 526 (while (setq buf (pop buffers))
519 (setq buf (cdar buffers)) 527 (when (get-buffer-window buf)
520 (when (symbolp buf) 528 (push buf bufs)
521 (setq buf (and (boundp buf) (symbol-value buf)))) 529 (pop-to-buffer buf)
522 (and buf 530 (when (or (not lowest)
523 (get-buffer-window buf) 531 (< (gnus-window-top-edge) lowest))
524 (progn 532 (setq lowest (gnus-window-top-edge)
525 (push buf bufs) 533 lowest-buf buf))))
526 (pop-to-buffer buf)
527 (when (or (not lowest)
528 (< (gnus-window-top-edge) lowest))
529 (setq lowest (gnus-window-top-edge))
530 (setq lowest-buf buf))))
531 (setq buffers (cdr buffers)))
532 ;; Remove windows on *all* summary buffers.
533 (walk-windows
534 (lambda (win)
535 (let ((buf (window-buffer win)))
536 (when (string-match "^\\*Summary" (buffer-name buf))
537 (push buf bufs)
538 (pop-to-buffer buf)
539 (when (or (not lowest)
540 (< (gnus-window-top-edge) lowest))
541 (setq lowest-buf buf)
542 (setq lowest (gnus-window-top-edge)))))))
543 (when lowest-buf 534 (when lowest-buf
544 (pop-to-buffer lowest-buf) 535 (pop-to-buffer lowest-buf)
545 (switch-to-buffer nntp-server-buffer)) 536 (switch-to-buffer nntp-server-buffer))
546 (while bufs 537 (mapcar (lambda (b) (delete-windows-on b t)) bufs))))
547 (when (not (eq (car bufs) lowest-buf))
548 (delete-windows-on (car bufs)))
549 (setq bufs (cdr bufs))))))
550 538
551(provide 'gnus-win) 539(provide 'gnus-win)
552 540
diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el
index e1368c61d72..a59c3873890 100644
--- a/lisp/gnus/gnus.el
+++ b/lisp/gnus/gnus.el
@@ -1,8 +1,8 @@
1;;; gnus.el --- a newsreader for GNU Emacs 1;;; gnus.el --- a newsreader for GNU Emacs
2;; Copyright (C) 1987,88,89,90,93,94,95,96,97 Free Software Foundation, Inc. 2;; Copyright (C) 1987,88,89,90,93,94,95,96,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> 4;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
5;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 5;; Lars Magne Ingebrigtsen <larsi@gnus.org>
6;; Keywords: news, mail 6;; Keywords: news, mail
7 7
8;; This file is part of GNU Emacs. 8;; This file is part of GNU Emacs.
@@ -30,8 +30,12 @@
30 30
31(eval-when-compile (require 'cl)) 31(eval-when-compile (require 'cl))
32 32
33(eval-when-compile (require 'cl))
34
33(require 'custom) 35(require 'custom)
34(require 'gnus-load) 36(eval-and-compile
37 (if (< emacs-major-version 20)
38 (require 'gnus-load)))
35(require 'message) 39(require 'message)
36 40
37(defgroup gnus nil 41(defgroup gnus nil
@@ -39,6 +43,10 @@
39 :group 'news 43 :group 'news
40 :group 'mail) 44 :group 'mail)
41 45
46(defgroup gnus-cache nil
47 "Cache interface."
48 :group 'gnus)
49
42(defgroup gnus-start nil 50(defgroup gnus-start nil
43 "Starting your favorite newsreader." 51 "Starting your favorite newsreader."
44 :group 'gnus) 52 :group 'gnus)
@@ -203,6 +211,10 @@
203 :group 'gnus 211 :group 'gnus
204 :group 'faces) 212 :group 'faces)
205 213
214(defgroup gnus-agent nil
215 "Offline support for Gnus."
216 :group 'gnus)
217
206(defgroup gnus-files nil 218(defgroup gnus-files nil
207 "Files used by Gnus." 219 "Files used by Gnus."
208 :group 'gnus) 220 :group 'gnus)
@@ -240,7 +252,7 @@ is restarted, and sometimes reloaded."
240 :link '(custom-manual "(gnus)Exiting Gnus") 252 :link '(custom-manual "(gnus)Exiting Gnus")
241 :group 'gnus) 253 :group 'gnus)
242 254
243(defconst gnus-version-number "5.5" 255(defconst gnus-version-number "5.7"
244 "Version number for this version of Gnus.") 256 "Version number for this version of Gnus.")
245 257
246(defconst gnus-version (format "Gnus v%s" gnus-version-number) 258(defconst gnus-version (format "Gnus v%s" gnus-version-number)
@@ -262,6 +274,7 @@ be set in `.emacs' instead."
262 274
263(unless (featurep 'gnus-xmas) 275(unless (featurep 'gnus-xmas)
264 (defalias 'gnus-make-overlay 'make-overlay) 276 (defalias 'gnus-make-overlay 'make-overlay)
277 (defalias 'gnus-delete-overlay 'delete-overlay)
265 (defalias 'gnus-overlay-put 'overlay-put) 278 (defalias 'gnus-overlay-put 'overlay-put)
266 (defalias 'gnus-move-overlay 'move-overlay) 279 (defalias 'gnus-move-overlay 'move-overlay)
267 (defalias 'gnus-overlay-end 'overlay-end) 280 (defalias 'gnus-overlay-end 'overlay-end)
@@ -276,47 +289,10 @@ be set in `.emacs' instead."
276 (defalias 'gnus-put-text-property 'put-text-property) 289 (defalias 'gnus-put-text-property 'put-text-property)
277 (defalias 'gnus-mode-line-buffer-identification 'identity) 290 (defalias 'gnus-mode-line-buffer-identification 'identity)
278 (defalias 'gnus-characterp 'numberp) 291 (defalias 'gnus-characterp 'numberp)
292 (defalias 'gnus-deactivate-mark 'deactivate-mark)
293 (defalias 'gnus-window-edges 'window-edges)
279 (defalias 'gnus-key-press-event-p 'numberp)) 294 (defalias 'gnus-key-press-event-p 'numberp))
280 295
281;; The XEmacs people think this is evil, so it must go.
282(defun custom-face-lookup (&optional fg bg stipple bold italic underline)
283 "Lookup or create a face with specified attributes."
284 (let ((name (intern (format "custom-face-%s-%s-%s-%S-%S-%S"
285 (or fg "default")
286 (or bg "default")
287 (or stipple "default")
288 bold italic underline))))
289 (if (and (custom-facep name)
290 (fboundp 'make-face))
291 ()
292 (copy-face 'default name)
293 (when (and fg
294 (not (string-equal fg "default")))
295 (ignore-errors
296 (set-face-foreground name fg)))
297 (when (and bg
298 (not (string-equal bg "default")))
299 (ignore-errors
300 (set-face-background name bg)))
301 (when (and stipple
302 (not (string-equal stipple "default"))
303 (not (eq stipple 'custom:asis))
304 (fboundp 'set-face-stipple))
305 (set-face-stipple name stipple))
306 (when (and bold
307 (not (eq bold 'custom:asis)))
308 (ignore-errors
309 (make-face-bold name)))
310 (when (and italic
311 (not (eq italic 'custom:asis)))
312 (ignore-errors
313 (make-face-italic name)))
314 (when (and underline
315 (not (eq underline 'custom:asis)))
316 (ignore-errors
317 (set-face-underline-p name t))))
318 name))
319
320;; We define these group faces here to avoid the display 296;; We define these group faces here to avoid the display
321;; update forced when creating new faces. 297;; update forced when creating new faces.
322 298
@@ -626,6 +602,33 @@ be set in `.emacs' instead."
626 "Face used for normal interest read articles.") 602 "Face used for normal interest read articles.")
627 603
628 604
605;;;
606;;; Gnus buffers
607;;;
608
609(defvar gnus-buffers nil)
610
611(defun gnus-get-buffer-create (name)
612 "Do the same as `get-buffer-create', but store the created buffer."
613 (or (get-buffer name)
614 (car (push (get-buffer-create name) gnus-buffers))))
615
616(defun gnus-add-buffer ()
617 "Add the current buffer to the list of Gnus buffers."
618 (push (current-buffer) gnus-buffers))
619
620(defun gnus-buffers ()
621 "Return a list of live Gnus buffers."
622 (while (and gnus-buffers
623 (not (buffer-name (car gnus-buffers))))
624 (pop gnus-buffers))
625 (let ((buffers gnus-buffers))
626 (while (cdr buffers)
627 (if (buffer-name (cadr buffers))
628 (pop buffers)
629 (setcdr buffers (cddr buffers)))))
630 gnus-buffers)
631
629;;; Splash screen. 632;;; Splash screen.
630 633
631(defvar gnus-group-buffer "*Group*") 634(defvar gnus-group-buffer "*Group*")
@@ -636,17 +639,17 @@ be set in `.emacs' instead."
636(defface gnus-splash-face 639(defface gnus-splash-face
637 '((((class color) 640 '((((class color)
638 (background dark)) 641 (background dark))
639 (:foreground "red")) 642 (:foreground "ForestGreen"))
640 (((class color) 643 (((class color)
641 (background light)) 644 (background light))
642 (:foreground "red")) 645 (:foreground "ForestGreen"))
643 (t 646 (t
644 ())) 647 ()))
645 "Level 1 newsgroup face.") 648 "Level 1 newsgroup face.")
646 649
647(defun gnus-splash () 650(defun gnus-splash ()
648 (save-excursion 651 (save-excursion
649 (switch-to-buffer gnus-group-buffer) 652 (switch-to-buffer (gnus-get-buffer-create gnus-group-buffer))
650 (let ((buffer-read-only nil)) 653 (let ((buffer-read-only nil))
651 (erase-buffer) 654 (erase-buffer)
652 (unless gnus-inhibit-startup-message 655 (unless gnus-inhibit-startup-message
@@ -714,9 +717,10 @@ be set in `.emacs' instead."
714 717
715(eval-when (load) 718(eval-when (load)
716 (let ((command (format "%s" this-command))) 719 (let ((command (format "%s" this-command)))
717 (when (and (string-match "gnus" command) 720 (if (and (string-match "gnus" command)
718 (not (string-match "gnus-other-frame" command))) 721 (not (string-match "gnus-other-frame" command)))
719 (gnus-splash)))) 722 (gnus-splash)
723 (gnus-get-buffer-create gnus-group-buffer))))
720 724
721;;; Do the rest. 725;;; Do the rest.
722 726
@@ -732,7 +736,12 @@ All other Gnus path variables are initialized from this variable."
732 736
733(defcustom gnus-directory (or (getenv "SAVEDIR") 737(defcustom gnus-directory (or (getenv "SAVEDIR")
734 (nnheader-concat gnus-home-directory "News/")) 738 (nnheader-concat gnus-home-directory "News/"))
735 "Directory variable from which all other Gnus file variables are derived." 739 "*Directory variable from which all other Gnus file variables are derived.
740
741Note that Gnus is mostly loaded when the `.gnus.el' file is read.
742This means that other directory variables that are initialized from
743this variable won't be set properly if you set this variable in `.gnus.el'.
744Set this variable in `.emacs' instead."
736 :group 'gnus-files 745 :group 'gnus-files
737 :type 'directory) 746 :type 'directory)
738 747
@@ -774,7 +783,7 @@ used to 899, you would say something along these lines:
774 (or (getenv "NNTPSERVER") 783 (or (getenv "NNTPSERVER")
775 (and (file-readable-p gnus-nntpserver-file) 784 (and (file-readable-p gnus-nntpserver-file)
776 (save-excursion 785 (save-excursion
777 (set-buffer (get-buffer-create " *gnus nntp*")) 786 (set-buffer (gnus-get-buffer-create " *gnus nntp*"))
778 (buffer-disable-undo (current-buffer)) 787 (buffer-disable-undo (current-buffer))
779 (insert-file-contents gnus-nntpserver-file) 788 (insert-file-contents gnus-nntpserver-file)
780 (let ((name (buffer-string))) 789 (let ((name (buffer-string)))
@@ -799,7 +808,7 @@ used to 899, you would say something along these lines:
799 nil 808 nil
800 (list gnus-nntp-service))) 809 (list gnus-nntp-service)))
801 (error nil)) 810 (error nil))
802 "Default method for selecting a newsgroup. 811 "*Default method for selecting a newsgroup.
803This variable should be a list, where the first element is how the 812This variable should be a list, where the first element is how the
804news is to be fetched, the second is the address. 813news is to be fetched, the second is the address.
805 814
@@ -827,7 +836,7 @@ see the manual for details."
827 ,(nnheader-concat message-directory "archive/active")) 836 ,(nnheader-concat message-directory "archive/active"))
828 (nnfolder-get-new-mail nil) 837 (nnfolder-get-new-mail nil)
829 (nnfolder-inhibit-expiry t)) 838 (nnfolder-inhibit-expiry t))
830 "Method used for archiving messages you've sent. 839 "*Method used for archiving messages you've sent.
831This should be a mail method. 840This should be a mail method.
832 841
833It's probably not a very effective to change this variable once you've 842It's probably not a very effective to change this variable once you've
@@ -859,6 +868,7 @@ that case, just return a fully prefixed name of the group --
859\"nnml+private:mail.misc\", for instance." 868\"nnml+private:mail.misc\", for instance."
860 :group 'gnus-message 869 :group 'gnus-message
861 :type '(choice (const :tag "none" nil) 870 :type '(choice (const :tag "none" nil)
871 sexp
862 string)) 872 string))
863 873
864(defcustom gnus-secondary-servers nil 874(defcustom gnus-secondary-servers nil
@@ -932,7 +942,7 @@ in the documentation of `gnus-select-method'."
932 "/ftp@nctuccca.edu.tw:/USENET/FAQ/" 942 "/ftp@nctuccca.edu.tw:/USENET/FAQ/"
933 "/ftp@hwarang.postech.ac.kr:/pub/usenet/" 943 "/ftp@hwarang.postech.ac.kr:/pub/usenet/"
934 "/ftp@ftp.hk.super.net:/mirror/faqs/") 944 "/ftp@ftp.hk.super.net:/mirror/faqs/")
935 "Directory where the group FAQs are stored. 945 "*Directory where the group FAQs are stored.
936This will most commonly be on a remote machine, and the file will be 946This will most commonly be on a remote machine, and the file will be
937fetched by ange-ftp. 947fetched by ange-ftp.
938 948
@@ -1090,7 +1100,7 @@ articles. This is not a good idea."
1090 1100
1091(defcustom gnus-summary-prepare-exit-hook 1101(defcustom gnus-summary-prepare-exit-hook
1092 '(gnus-summary-expire-articles) 1102 '(gnus-summary-expire-articles)
1093 "A hook called when preparing to exit from the summary buffer. 1103 "*A hook called when preparing to exit from the summary buffer.
1094It calls `gnus-summary-expire-articles' by default." 1104It calls `gnus-summary-expire-articles' by default."
1095 :group 'gnus-summary-exit 1105 :group 'gnus-summary-exit
1096 :type 'hook) 1106 :type 'hook)
@@ -1104,7 +1114,8 @@ required."
1104 1114
1105(defcustom gnus-expert-user nil 1115(defcustom gnus-expert-user nil
1106 "*Non-nil means that you will never be asked for confirmation about anything. 1116 "*Non-nil means that you will never be asked for confirmation about anything.
1107And that means *anything*." 1117That doesn't mean *anything* anything; particularly destructive
1118commands will still require prompting."
1108 :group 'gnus-meta 1119 :group 'gnus-meta
1109 :type 'boolean) 1120 :type 'boolean)
1110 1121
@@ -1154,9 +1165,11 @@ slower."
1154 ("nnsoup" post-mail address) 1165 ("nnsoup" post-mail address)
1155 ("nndraft" post-mail) 1166 ("nndraft" post-mail)
1156 ("nnfolder" mail respool address) 1167 ("nnfolder" mail respool address)
1157 ("nngateway" none address prompt-address physical-address) 1168 ("nngateway" post-mail address prompt-address physical-address)
1158 ("nnweb" none)) 1169 ("nnweb" none)
1159 "An alist of valid select methods. 1170 ("nnlistserv" none)
1171 ("nnagent" post-mail))
1172 "*An alist of valid select methods.
1160The first element of each list lists should be a string with the name 1173The first element of each list lists should be a string with the name
1161of the select method. The other elements may be the category of 1174of the select method. The other elements may be the category of
1162this method (i. e., `post', `mail', `none' or whatever) or other 1175this method (i. e., `post', `mail', `none' or whatever) or other
@@ -1283,7 +1296,7 @@ It is called with three parameters -- GROUP, LEVEL and OLDLEVEL."
1283 browse-menu server-menu 1296 browse-menu server-menu
1284 page-marker tree-menu binary-menu pick-menu 1297 page-marker tree-menu binary-menu pick-menu
1285 grouplens-menu) 1298 grouplens-menu)
1286 "Enable visual features. 1299 "*Enable visual features.
1287If `visual' is disabled, there will be no menus and few faces. Most of 1300If `visual' is disabled, there will be no menus and few faces. Most of
1288the visual customization options below will be ignored. Gnus will use 1301the visual customization options below will be ignored. Gnus will use
1289less space and be faster as a result. 1302less space and be faster as a result.
@@ -1326,7 +1339,7 @@ and `grouplens-menu'."
1326 'highlight) 1339 'highlight)
1327 'default) 1340 'default)
1328 (error 'highlight)) 1341 (error 'highlight))
1329 "Face used for group or summary buffer mouse highlighting. 1342 "*Face used for group or summary buffer mouse highlighting.
1330The line beneath the mouse pointer will be highlighted with this 1343The line beneath the mouse pointer will be highlighted with this
1331face." 1344face."
1332 :group 'gnus-visual 1345 :group 'gnus-visual
@@ -1344,7 +1357,7 @@ face."
1344 gnus-article-hide-boring-headers 1357 gnus-article-hide-boring-headers
1345 gnus-article-treat-overstrike 1358 gnus-article-treat-overstrike
1346 gnus-article-maybe-highlight)) 1359 gnus-article-maybe-highlight))
1347 "Controls how the article buffer will look. 1360 "*Controls how the article buffer will look.
1348 1361
1349If you leave the list empty, the article will appear exactly as it is 1362If you leave the list empty, the article will appear exactly as it is
1350stored on the disk. The list entries will hide or highlight various 1363stored on the disk. The list entries will hide or highlight various
@@ -1391,12 +1404,22 @@ want."
1391 :group 'gnus-article-saving 1404 :group 'gnus-article-saving
1392 :type 'directory) 1405 :type 'directory)
1393 1406
1407(defvar gnus-plugged t
1408 "Whether Gnus is plugged or not.")
1409
1394 1410
1395;;; Internal variables 1411;;; Internal variables
1396 1412
1397(defvar gnus-group-get-parameter-function 'gnus-group-get-parameter) 1413(defvar gnus-group-get-parameter-function 'gnus-group-get-parameter)
1398(defvar gnus-original-article-buffer " *Original Article*") 1414(defvar gnus-original-article-buffer " *Original Article*")
1399(defvar gnus-newsgroup-name nil) 1415(defvar gnus-newsgroup-name nil)
1416(defvar gnus-ephemeral-servers nil)
1417
1418(defvar gnus-agent nil
1419 "Whether we want to use the Gnus agent or not.")
1420
1421(defvar gnus-command-method nil
1422 "Dynamically bound variable that says what the current backend is.")
1400 1423
1401(defvar gnus-current-select-method nil 1424(defvar gnus-current-select-method nil
1402 "The current method for selecting a newsgroup.") 1425 "The current method for selecting a newsgroup.")
@@ -1409,7 +1432,6 @@ want."
1409 1432
1410;; Variable holding the user answers to all method prompts. 1433;; Variable holding the user answers to all method prompts.
1411(defvar gnus-method-history nil) 1434(defvar gnus-method-history nil)
1412(defvar gnus-group-history nil)
1413 1435
1414;; Variable holding the user answers to all mail method prompts. 1436;; Variable holding the user answers to all mail method prompts.
1415(defvar gnus-mail-method-history nil) 1437(defvar gnus-mail-method-history nil)
@@ -1420,12 +1442,19 @@ want."
1420(defvar gnus-server-alist nil 1442(defvar gnus-server-alist nil
1421 "List of available servers.") 1443 "List of available servers.")
1422 1444
1445(defcustom gnus-cache-directory
1446 (nnheader-concat gnus-directory "cache/")
1447 "*The directory where cached articles will be stored."
1448 :group 'gnus-cache
1449 :type 'directory)
1450
1423(defvar gnus-predefined-server-alist 1451(defvar gnus-predefined-server-alist
1424 `(("cache" 1452 `(("cache"
1425 (nnspool "cache" 1453 nnspool "cache"
1426 (nnspool-spool-directory "~/News/cache/") 1454 (nnspool-spool-directory ,gnus-cache-directory)
1427 (nnspool-nov-directory "~/News/cache/") 1455 (nnspool-nov-directory ,gnus-cache-directory)
1428 (nnspool-active-file "~/News/cache/active")))) 1456 (nnspool-active-file
1457 ,(nnheader-concat gnus-cache-directory "active"))))
1429 "List of predefined (convenience) servers.") 1458 "List of predefined (convenience) servers.")
1430 1459
1431(defvar gnus-topic-indentation "") ;; Obsolete variable. 1460(defvar gnus-topic-indentation "") ;; Obsolete variable.
@@ -1435,7 +1464,8 @@ want."
1435 (expirable . expire) (killed . killed) 1464 (expirable . expire) (killed . killed)
1436 (bookmarks . bookmark) (dormant . dormant) 1465 (bookmarks . bookmark) (dormant . dormant)
1437 (scored . score) (saved . save) 1466 (scored . score) (saved . save)
1438 (cached . cache))) 1467 (cached . cache) (downloadable . download)
1468 (unsendable . unsend)))
1439 1469
1440(defvar gnus-headers-retrieved-by nil) 1470(defvar gnus-headers-retrieved-by nil)
1441(defvar gnus-article-reply nil) 1471(defvar gnus-article-reply nil)
@@ -1466,9 +1496,6 @@ want."
1466(defvar gnus-article-buffer "*Article*") 1496(defvar gnus-article-buffer "*Article*")
1467(defvar gnus-server-buffer "*Server*") 1497(defvar gnus-server-buffer "*Server*")
1468 1498
1469(defvar gnus-buffer-list nil
1470 "Gnus buffers that should be killed on exit.")
1471
1472(defvar gnus-slave nil 1499(defvar gnus-slave nil
1473 "Whether this Gnus is a slave or not.") 1500 "Whether this Gnus is a slave or not.")
1474 1501
@@ -1548,6 +1575,7 @@ gnus-newsrc-hashtb should be kept so that both hold the same information.")
1548 ("pp" pp pp-to-string pp-eval-expression) 1575 ("pp" pp pp-to-string pp-eval-expression)
1549 ("ps-print" ps-print-preprint) 1576 ("ps-print" ps-print-preprint)
1550 ("mail-extr" mail-extract-address-components) 1577 ("mail-extr" mail-extract-address-components)
1578 ("browse-url" browse-url)
1551 ("message" :interactive t 1579 ("message" :interactive t
1552 message-send-and-exit message-yank-original) 1580 message-send-and-exit message-yank-original)
1553 ("nnmail" nnmail-split-fancy nnmail-article-group nnmail-date-to-time) 1581 ("nnmail" nnmail-split-fancy nnmail-article-group nnmail-date-to-time)
@@ -1556,7 +1584,8 @@ gnus-newsrc-hashtb should be kept so that both hold the same information.")
1556 timezone-make-sortable-date timezone-make-time-string) 1584 timezone-make-sortable-date timezone-make-time-string)
1557 ("rmailout" rmail-output) 1585 ("rmailout" rmail-output)
1558 ("rmail" rmail-insert-rmail-file-header rmail-count-new-messages 1586 ("rmail" rmail-insert-rmail-file-header rmail-count-new-messages
1559 rmail-show-message) 1587 rmail-show-message rmail-summary-exists
1588 rmail-select-summary rmail-update-summary)
1560 ("gnus-audio" :interactive t gnus-audio-play) 1589 ("gnus-audio" :interactive t gnus-audio-play)
1561 ("gnus-xmas" gnus-xmas-splash) 1590 ("gnus-xmas" gnus-xmas-splash)
1562 ("gnus-soup" :interactive t 1591 ("gnus-soup" :interactive t
@@ -1577,7 +1606,8 @@ gnus-newsrc-hashtb should be kept so that both hold the same information.")
1577 gnus-tree-open gnus-tree-close gnus-carpal-setup-buffer) 1606 gnus-tree-open gnus-tree-close gnus-carpal-setup-buffer)
1578 ("gnus-nocem" gnus-nocem-scan-groups gnus-nocem-close 1607 ("gnus-nocem" gnus-nocem-scan-groups gnus-nocem-close
1579 gnus-nocem-unwanted-article-p) 1608 gnus-nocem-unwanted-article-p)
1580 ("gnus-srvr" gnus-enter-server-buffer gnus-server-set-info) 1609 ("gnus-srvr" gnus-enter-server-buffer gnus-server-set-info
1610 gnus-server-server-name)
1581 ("gnus-srvr" gnus-browse-foreign-server) 1611 ("gnus-srvr" gnus-browse-foreign-server)
1582 ("gnus-cite" :interactive t 1612 ("gnus-cite" :interactive t
1583 gnus-article-highlight-citation gnus-article-hide-citation-maybe 1613 gnus-article-highlight-citation gnus-article-hide-citation-maybe
@@ -1623,8 +1653,10 @@ gnus-newsrc-hashtb should be kept so that both hold the same information.")
1623 gnus-uu-decode-binhex gnus-uu-decode-uu-view 1653 gnus-uu-decode-binhex gnus-uu-decode-uu-view
1624 gnus-uu-decode-uu-and-save-view gnus-uu-decode-unshar-view 1654 gnus-uu-decode-uu-and-save-view gnus-uu-decode-unshar-view
1625 gnus-uu-decode-unshar-and-save-view gnus-uu-decode-save-view 1655 gnus-uu-decode-unshar-and-save-view gnus-uu-decode-save-view
1626 gnus-uu-decode-binhex-view) 1656 gnus-uu-decode-binhex-view gnus-uu-unmark-thread
1627 ("gnus-uu" gnus-uu-delete-work-dir gnus-quote-arg-for-sh-or-csh) 1657 gnus-uu-mark-over gnus-uu-post-news gnus-uu-post-news)
1658 ("gnus-uu" gnus-uu-delete-work-dir gnus-quote-arg-for-sh-or-csh
1659 gnus-uu-unmark-thread)
1628 ("gnus-msg" (gnus-summary-send-map keymap) 1660 ("gnus-msg" (gnus-summary-send-map keymap)
1629 gnus-article-mail gnus-copy-article-buffer gnus-extended-version) 1661 gnus-article-mail gnus-copy-article-buffer gnus-extended-version)
1630 ("gnus-msg" :interactive t 1662 ("gnus-msg" :interactive t
@@ -1639,7 +1671,11 @@ gnus-newsrc-hashtb should be kept so that both hold the same information.")
1639 gnus-post-news gnus-summary-reply gnus-summary-reply-with-original 1671 gnus-post-news gnus-summary-reply gnus-summary-reply-with-original
1640 gnus-summary-mail-forward gnus-summary-mail-other-window 1672 gnus-summary-mail-forward gnus-summary-mail-other-window
1641 gnus-summary-resend-message gnus-summary-resend-bounced-mail 1673 gnus-summary-resend-message gnus-summary-resend-bounced-mail
1642 gnus-bug) 1674 gnus-summary-wide-reply gnus-summary-followup-to-mail
1675 gnus-summary-followup-to-mail-with-original gnus-bug
1676 gnus-summary-wide-reply-with-original
1677 gnus-summary-post-forward gnus-summary-wide-reply-with-original
1678 gnus-summary-post-forward)
1643 ("gnus-picon" :interactive t gnus-article-display-picons 1679 ("gnus-picon" :interactive t gnus-article-display-picons
1644 gnus-group-display-picons gnus-picons-article-display-x-face 1680 gnus-group-display-picons gnus-picons-article-display-x-face
1645 gnus-picons-display-x-face) 1681 gnus-picons-display-x-face)
@@ -1650,12 +1686,16 @@ gnus-newsrc-hashtb should be kept so that both hold the same information.")
1650 ("gnus-sum" gnus-summary-insert-line gnus-summary-read-group 1686 ("gnus-sum" gnus-summary-insert-line gnus-summary-read-group
1651 gnus-list-of-unread-articles gnus-list-of-read-articles 1687 gnus-list-of-unread-articles gnus-list-of-read-articles
1652 gnus-offer-save-summaries gnus-make-thread-indent-array 1688 gnus-offer-save-summaries gnus-make-thread-indent-array
1653 gnus-summary-exit gnus-update-read-articles) 1689 gnus-summary-exit gnus-update-read-articles gnus-summary-last-subject
1690 gnus-summary-skip-intangible gnus-summary-article-number
1691 gnus-data-header gnus-data-find)
1654 ("gnus-group" gnus-group-insert-group-line gnus-group-quit 1692 ("gnus-group" gnus-group-insert-group-line gnus-group-quit
1655 gnus-group-list-groups gnus-group-first-unread-group 1693 gnus-group-list-groups gnus-group-first-unread-group
1656 gnus-group-set-mode-line gnus-group-set-info gnus-group-save-newsrc 1694 gnus-group-set-mode-line gnus-group-set-info gnus-group-save-newsrc
1657 gnus-group-setup-buffer gnus-group-get-new-news 1695 gnus-group-setup-buffer gnus-group-get-new-news
1658 gnus-group-make-help-group gnus-group-update-group) 1696 gnus-group-make-help-group gnus-group-update-group
1697 gnus-clear-inboxes-moved gnus-group-iterate
1698 gnus-group-group-name)
1659 ("gnus-bcklg" gnus-backlog-request-article gnus-backlog-enter-article 1699 ("gnus-bcklg" gnus-backlog-request-article gnus-backlog-enter-article
1660 gnus-backlog-remove-article) 1700 gnus-backlog-remove-article)
1661 ("gnus-art" gnus-article-read-summary-keys gnus-article-save 1701 ("gnus-art" gnus-article-read-summary-keys gnus-article-save
@@ -1675,10 +1715,11 @@ gnus-newsrc-hashtb should be kept so that both hold the same information.")
1675 gnus-article-date-original gnus-article-date-lapsed 1715 gnus-article-date-original gnus-article-date-lapsed
1676 gnus-article-show-all-headers 1716 gnus-article-show-all-headers
1677 gnus-article-edit-mode gnus-article-edit-article 1717 gnus-article-edit-mode gnus-article-edit-article
1678 gnus-article-edit-done gnus-decode-rfc1522 article-decode-rfc1522) 1718 gnus-article-edit-done gnus-decode-rfc1522 article-decode-rfc1522
1719 gnus-start-date-timer gnus-stop-date-timer)
1679 ("gnus-int" gnus-request-type) 1720 ("gnus-int" gnus-request-type)
1680 ("gnus-start" gnus-newsrc-parse-options gnus-1 gnus-no-server-1 1721 ("gnus-start" gnus-newsrc-parse-options gnus-1 gnus-no-server-1
1681 gnus-dribble-enter) 1722 gnus-dribble-enter gnus-read-init-file gnus-dribble-touch)
1682 ("gnus-dup" gnus-dup-suppress-articles gnus-dup-unsuppress-article 1723 ("gnus-dup" gnus-dup-suppress-articles gnus-dup-unsuppress-article
1683 gnus-dup-enter-articles) 1724 gnus-dup-enter-articles)
1684 ("gnus-range" gnus-copy-sequence) 1725 ("gnus-range" gnus-copy-sequence)
@@ -1690,13 +1731,20 @@ gnus-newsrc-hashtb should be kept so that both hold the same information.")
1690 ("gnus-async" gnus-async-request-fetched-article gnus-async-prefetch-next 1731 ("gnus-async" gnus-async-request-fetched-article gnus-async-prefetch-next
1691 gnus-async-prefetch-article gnus-async-prefetch-remove-group 1732 gnus-async-prefetch-article gnus-async-prefetch-remove-group
1692 gnus-async-halt-prefetch) 1733 gnus-async-halt-prefetch)
1734 ("gnus-agent" gnus-open-agent gnus-agent-get-function
1735 gnus-agent-save-groups gnus-agent-save-active gnus-agent-method-p
1736 gnus-agent-get-undownloaded-list gnus-agent-fetch-session
1737 gnus-summary-set-agent-mark gnus-agent-save-group-info)
1738 ("gnus-agent" :interactive t
1739 gnus-unplugged gnus-agentize gnus-agent-batch)
1693 ("gnus-vm" :interactive t gnus-summary-save-in-vm 1740 ("gnus-vm" :interactive t gnus-summary-save-in-vm
1694 gnus-summary-save-article-vm)))) 1741 gnus-summary-save-article-vm)
1742 ("gnus-draft" :interactive t gnus-draft-mode gnus-group-send-drafts))))
1695 1743
1696;;; gnus-sum.el thingies 1744;;; gnus-sum.el thingies
1697 1745
1698 1746
1699(defcustom gnus-summary-line-format "%U\%R\%z\%I\%(%[%4L: %-20,20n%]%) %s\n" 1747(defcustom gnus-summary-line-format "%U%R%z%I%(%[%4L: %-20,20n%]%) %s\n"
1700 "*The format specification of the lines in the summary buffer. 1748 "*The format specification of the lines in the summary buffer.
1701 1749
1702It works along the same lines as a normal formatting string, 1750It works along the same lines as a normal formatting string,
@@ -1732,6 +1780,7 @@ with some simple extensions.
1732%l GroupLens score (string). 1780%l GroupLens score (string).
1733%V Total thread score (number). 1781%V Total thread score (number).
1734%P The line number (number). 1782%P The line number (number).
1783%O Download mark (character).
1735%u User defined specifier. The next character in the format string should 1784%u User defined specifier. The next character in the format string should
1736 be a letter. Gnus will call the function gnus-user-format-function-X, 1785 be a letter. Gnus will call the function gnus-user-format-function-X,
1737 where X is the letter following %u. The function will be passed the 1786 where X is the letter following %u. The function will be passed the
@@ -1763,7 +1812,7 @@ This restriction may disappear in later versions of Gnus."
1763 1812
1764(defun gnus-suppress-keymap (keymap) 1813(defun gnus-suppress-keymap (keymap)
1765 (suppress-keymap keymap) 1814 (suppress-keymap keymap)
1766 (let ((keys `([delete] "\177" "\M-u"))) ;gnus-mouse-2 1815 (let ((keys `([backspace] [delete] "\177" "\M-u"))) ;gnus-mouse-2
1767 (while keys 1816 (while keys
1768 (define-key keymap (pop keys) 'undefined)))) 1817 (define-key keymap (pop keys) 'undefined))))
1769 1818
@@ -1818,14 +1867,6 @@ This restriction may disappear in later versions of Gnus."
1818 "Set GROUP's active info." 1867 "Set GROUP's active info."
1819 `(gnus-sethash ,group ,active gnus-active-hashtb)) 1868 `(gnus-sethash ,group ,active gnus-active-hashtb))
1820 1869
1821(defun gnus-alive-p ()
1822 "Say whether Gnus is running or not."
1823 (and gnus-group-buffer
1824 (get-buffer gnus-group-buffer)
1825 (save-excursion
1826 (set-buffer gnus-group-buffer)
1827 (eq major-mode 'gnus-group-mode))))
1828
1829;; Info access macros. 1870;; Info access macros.
1830 1871
1831(defmacro gnus-info-group (info) 1872(defmacro gnus-info-group (info)
@@ -1930,6 +1971,7 @@ This restriction may disappear in later versions of Gnus."
1930;;; Gnus Utility Functions 1971;;; Gnus Utility Functions
1931;;; 1972;;;
1932 1973
1974
1933(defmacro gnus-string-or (&rest strings) 1975(defmacro gnus-string-or (&rest strings)
1934 "Return the first element of STRINGS that is a non-blank string. 1976 "Return the first element of STRINGS that is a non-blank string.
1935STRINGS will be evaluated in normal `or' order." 1977STRINGS will be evaluated in normal `or' order."
@@ -1944,43 +1986,27 @@ STRINGS will be evaluated in normal `or' order."
1944 (setq strings nil))) 1986 (setq strings nil)))
1945 string)) 1987 string))
1946 1988
1947;; Add the current buffer to the list of buffers to be killed on exit.
1948(defun gnus-add-current-to-buffer-list ()
1949 (or (memq (current-buffer) gnus-buffer-list)
1950 (push (current-buffer) gnus-buffer-list)))
1951
1952(defun gnus-version (&optional arg) 1989(defun gnus-version (&optional arg)
1953 "Version number of this version of Gnus. 1990 "Version number of this version of Gnus.
1954If ARG, insert string at point." 1991If ARG, insert string at point."
1955 (interactive "P") 1992 (interactive "P")
1956 (let ((methods gnus-valid-select-methods) 1993 (if arg
1957 (mess gnus-version) 1994 (insert (message gnus-version))
1958 meth) 1995 (message gnus-version)))
1959 ;; Go through all the legal select methods and add their version
1960 ;; numbers to the total version string. Only the backends that are
1961 ;; currently in use will have their message numbers taken into
1962 ;; consideration.
1963 (while methods
1964 (setq meth (intern (concat (caar methods) "-version")))
1965 (and (boundp meth)
1966 (stringp (symbol-value meth))
1967 (setq mess (concat mess "; " (symbol-value meth))))
1968 (setq methods (cdr methods)))
1969 (if arg
1970 (insert (message mess))
1971 (message mess))))
1972 1996
1973(defun gnus-continuum-version (version) 1997(defun gnus-continuum-version (version)
1974 "Return VERSION as a floating point number." 1998 "Return VERSION as a floating point number."
1975 (when (or (string-match "^\\([^ ]+\\)? ?Gnus v?\\([0-9.]+\\)$" version) 1999 (when (or (string-match "^\\([^ ]+\\)? ?Gnus v?\\([0-9.]+\\)$" version)
1976 (string-match "^\\(.?\\)gnus-\\([0-9.]+\\)$" version)) 2000 (string-match "^\\(.?\\)gnus-\\([0-9.]+\\)$" version))
1977 (let* ((alpha (and (match-beginning 1) (match-string 1 version))) 2001 (let ((alpha (and (match-beginning 1) (match-string 1 version)))
1978 (number (match-string 2 version)) 2002 (number (match-string 2 version))
1979 major minor least) 2003 major minor least)
1980 (string-match "\\([0-9]\\)\\.\\([0-9]+\\)\\.?\\([0-9]+\\)?" number) 2004 (unless (string-match
1981 (setq major (string-to-number (match-string 1 number))) 2005 "\\([0-9]\\)\\.\\([0-9]+\\)\\.?\\([0-9]+\\)?" number)
1982 (setq minor (string-to-number (match-string 2 number))) 2006 (error "Invalid version string: %s" version))
1983 (setq least (if (match-beginning 3) 2007 (setq major (string-to-number (match-string 1 number))
2008 minor (string-to-number (match-string 2 number))
2009 least (if (match-beginning 3)
1984 (string-to-number (match-string 3 number)) 2010 (string-to-number (match-string 3 number))
1985 0)) 2011 0))
1986 (string-to-number 2012 (string-to-number
@@ -1989,7 +2015,11 @@ If ARG, insert string at point."
1989 (cond 2015 (cond
1990 ((member alpha '("(ding)" "d")) "4.99") 2016 ((member alpha '("(ding)" "d")) "4.99")
1991 ((member alpha '("September" "s")) "5.01") 2017 ((member alpha '("September" "s")) "5.01")
1992 ((member alpha '("Red" "r")) "5.03")) 2018 ((member alpha '("Red" "r")) "5.03")
2019 ((member alpha '("Quassia" "q")) "5.05")
2020 ((member alpha '("p")) "5.07")
2021 ((member alpha '("o")) "5.09")
2022 ((member alpha '("n")) "5.11"))
1993 minor least) 2023 minor least)
1994 (format "%d.%02d%02d" major minor least)))))) 2024 (format "%d.%02d%02d" major minor least))))))
1995 2025
@@ -2002,6 +2032,124 @@ If ARG, insert string at point."
2002 (setq gnus-info-buffer (current-buffer)) 2032 (setq gnus-info-buffer (current-buffer))
2003 (gnus-configure-windows 'info))) 2033 (gnus-configure-windows 'info)))
2004 2034
2035;;;
2036;;; gnus-interactive
2037;;;
2038
2039(defvar gnus-current-prefix-symbol nil
2040 "Current prefix symbol.")
2041
2042(defvar gnus-current-prefix-symbols nil
2043 "List of current prefix symbols.")
2044
2045(defun gnus-interactive (string &optional params)
2046 "Return a list that can be fed to `interactive'.
2047See `interactive' for full documentation.
2048
2049Adds the following specs:
2050
2051y -- The current symbolic prefix.
2052Y -- A list of the current symbolic prefix(es).
2053A -- Article number.
2054H -- Article header.
2055g -- Group name."
2056 (let ((i 0)
2057 out c prompt)
2058 (while (< i (length string))
2059 (string-match ".\\([^\n]*\\)\n?" string i)
2060 (setq c (aref string i))
2061 (when (match-end 1)
2062 (setq prompt (match-string 1 string)))
2063 (setq i (match-end 0))
2064 ;; We basically emulate just about everything that
2065 ;; `interactive' does, but add the specs listed above.
2066 (push
2067 (cond
2068 ((= c ?a)
2069 (completing-read prompt obarray 'fboundp t))
2070 ((= c ?b)
2071 (read-buffer prompt (current-buffer) t))
2072 ((= c ?B)
2073 (read-buffer prompt (other-buffer (current-buffer))))
2074 ((= c ?c)
2075 (read-char))
2076 ((= c ?C)
2077 (completing-read prompt obarray 'commandp t))
2078 ((= c ?d)
2079 (point))
2080 ((= c ?D)
2081 (read-file-name prompt nil default-directory 'lambda))
2082 ((= c ?f)
2083 (read-file-name prompt nil nil 'lambda))
2084 ((= c ?F)
2085 (read-file-name prompt))
2086 ((= c ?k)
2087 (read-key-sequence prompt))
2088 ((= c ?K)
2089 (error "Not implemented spec"))
2090 ((= c ?e)
2091 (error "Not implemented spec"))
2092 ((= c ?m)
2093 (mark))
2094 ((= c ?N)
2095 (error "Not implemented spec"))
2096 ((= c ?n)
2097 (string-to-number (read-from-minibuffer prompt)))
2098 ((= c ?p)
2099 (prefix-numeric-value current-prefix-arg))
2100 ((= c ?P)
2101 current-prefix-arg)
2102 ((= c ?r)
2103 'gnus-prefix-nil)
2104 ((= c ?s)
2105 (read-string prompt))
2106 ((= c ?S)
2107 (intern (read-string prompt)))
2108 ((= c ?v)
2109 (read-variable prompt))
2110 ((= c ?x)
2111 (read-minibuffer prompt))
2112 ((= c ?x)
2113 (eval-minibuffer prompt))
2114 ;; And here the new specs come.
2115 ((= c ?y)
2116 gnus-current-prefix-symbol)
2117 ((= c ?Y)
2118 gnus-current-prefix-symbols)
2119 ((= c ?g)
2120 (gnus-group-group-name))
2121 ((= c ?A)
2122 (gnus-summary-skip-intangible)
2123 (or (get-text-property (point) 'gnus-number)
2124 (gnus-summary-last-subject)))
2125 ((= c ?H)
2126 (gnus-data-header (gnus-data-find (gnus-summary-article-number))))
2127 (t
2128 (error "Non-implemented spec")))
2129 out)
2130 (cond
2131 ((= c ?r)
2132 (push (if (< (point) (mark) (point) (mark))) out)
2133 (push (if (> (point) (mark) (point) (mark))) out))))
2134 (setq out (delq 'gnus-prefix-nil out))
2135 (nreverse out)))
2136
2137(defun gnus-symbolic-argument (&optional arg)
2138 "Read a symbolic argument and a command, and then execute command."
2139 (interactive "P")
2140 (let* ((in-command (this-command-keys))
2141 (command in-command)
2142 gnus-current-prefix-symbols
2143 gnus-current-prefix-symbol
2144 syms)
2145 (while (equal in-command command)
2146 (message "%s-" (key-description (this-command-keys)))
2147 (push (intern (char-to-string (read-char))) syms)
2148 (setq command (read-key-sequence nil t)))
2149 (setq gnus-current-prefix-symbols (nreverse syms)
2150 gnus-current-prefix-symbol (car gnus-current-prefix-symbols))
2151 (call-interactively (key-binding command t))))
2152
2005;;; More various functions. 2153;;; More various functions.
2006 2154
2007(defsubst gnus-check-backend-function (func group) 2155(defsubst gnus-check-backend-function (func group)
@@ -2055,7 +2203,14 @@ that that variable is buffer-local to the summary buffers."
2055 "Return non-nil if GROUP (and ARTICLE) come from a news server." 2203 "Return non-nil if GROUP (and ARTICLE) come from a news server."
2056 (or (gnus-member-of-valid 'post group) ; Ordinary news group. 2204 (or (gnus-member-of-valid 'post group) ; Ordinary news group.
2057 (and (gnus-member-of-valid 'post-mail group) ; Combined group. 2205 (and (gnus-member-of-valid 'post-mail group) ; Combined group.
2058 (eq (gnus-request-type group article) 'news)))) 2206 (if (or (null article)
2207 (not (< article 0)))
2208 (eq (gnus-request-type group article) 'news)
2209 (if (not (vectorp article))
2210 nil
2211 ;; It's a real article.
2212 (eq (gnus-request-type group (mail-header-id article))
2213 'news))))))
2059 2214
2060;; Returns a list of writable groups. 2215;; Returns a list of writable groups.
2061(defun gnus-writable-groups () 2216(defun gnus-writable-groups ()
@@ -2086,11 +2241,11 @@ that that variable is buffer-local to the summary buffers."
2086 2241
2087(defun gnus-ephemeral-group-p (group) 2242(defun gnus-ephemeral-group-p (group)
2088 "Say whether GROUP is ephemeral or not." 2243 "Say whether GROUP is ephemeral or not."
2089 (gnus-group-get-parameter group 'quit-config)) 2244 (gnus-group-get-parameter group 'quit-config t))
2090 2245
2091(defun gnus-group-quit-config (group) 2246(defun gnus-group-quit-config (group)
2092 "Return the quit-config of GROUP." 2247 "Return the quit-config of GROUP."
2093 (gnus-group-get-parameter group 'quit-config)) 2248 (gnus-group-get-parameter group 'quit-config t))
2094 2249
2095(defun gnus-kill-ephemeral-group (group) 2250(defun gnus-kill-ephemeral-group (group)
2096 "Remove ephemeral GROUP from relevant structures." 2251 "Remove ephemeral GROUP from relevant structures."
@@ -2124,9 +2279,11 @@ that that variable is buffer-local to the summary buffers."
2124 (gnus-server-to-method method)) 2279 (gnus-server-to-method method))
2125 ((equal method gnus-select-method) 2280 ((equal method gnus-select-method)
2126 gnus-select-method) 2281 gnus-select-method)
2127 ((and (stringp (car method)) group) 2282 ((and (stringp (car method))
2283 group)
2128 (gnus-server-extend-method group method)) 2284 (gnus-server-extend-method group method))
2129 ((and method (not group) 2285 ((and method
2286 (not group)
2130 (equal (cadr method) "")) 2287 (equal (cadr method) ""))
2131 method) 2288 method)
2132 (t 2289 (t
@@ -2200,7 +2357,8 @@ that that variable is buffer-local to the summary buffers."
2200(defun gnus-group-prefixed-name (group method) 2357(defun gnus-group-prefixed-name (group method)
2201 "Return the whole name from GROUP and METHOD." 2358 "Return the whole name from GROUP and METHOD."
2202 (and (stringp method) (setq method (gnus-server-to-method method))) 2359 (and (stringp method) (setq method (gnus-server-to-method method)))
2203 (if (not method) 2360 (if (or (not method)
2361 (gnus-server-equal method "native"))
2204 group 2362 group
2205 (concat (format "%s" (car method)) 2363 (concat (format "%s" (car method))
2206 (when (and 2364 (when (and
@@ -2253,6 +2411,15 @@ You should probably use `gnus-find-method-for-group' instead."
2253 (setq methods (cdr methods))) 2411 (setq methods (cdr methods)))
2254 methods)) 2412 methods))
2255 2413
2414(defun gnus-groups-from-server (server)
2415 "Return a list of all groups that are fetched from SERVER."
2416 (let ((alist (cdr gnus-newsrc-alist))
2417 info groups)
2418 (while (setq info (pop alist))
2419 (when (gnus-server-equal (gnus-info-method info) server)
2420 (push (gnus-info-group info) groups)))
2421 (sort groups 'string<)))
2422
2256(defun gnus-group-foreign-p (group) 2423(defun gnus-group-foreign-p (group)
2257 "Say whether a group is foreign or not." 2424 "Say whether a group is foreign or not."
2258 (and (not (gnus-group-native-p group)) 2425 (and (not (gnus-group-native-p group))
@@ -2266,28 +2433,41 @@ You should probably use `gnus-find-method-for-group' instead."
2266 "Say whether the group is secondary or not." 2433 "Say whether the group is secondary or not."
2267 (gnus-secondary-method-p (gnus-find-method-for-group group))) 2434 (gnus-secondary-method-p (gnus-find-method-for-group group)))
2268 2435
2269(defun gnus-group-find-parameter (group &optional symbol) 2436(defun gnus-group-find-parameter (group &optional symbol allow-list)
2270 "Return the group parameters for GROUP. 2437 "Return the group parameters for GROUP.
2271If SYMBOL, return the value of that symbol in the group parameters." 2438If SYMBOL, return the value of that symbol in the group parameters."
2272 (save-excursion 2439 (save-excursion
2273 (set-buffer gnus-group-buffer) 2440 (set-buffer gnus-group-buffer)
2274 (let ((parameters (funcall gnus-group-get-parameter-function group))) 2441 (let ((parameters (funcall gnus-group-get-parameter-function group)))
2275 (if symbol 2442 (if symbol
2276 (gnus-group-parameter-value parameters symbol) 2443 (gnus-group-parameter-value parameters symbol allow-list)
2277 parameters)))) 2444 parameters))))
2278 2445
2279(defun gnus-group-get-parameter (group &optional symbol) 2446(defun gnus-group-get-parameter (group &optional symbol allow-list)
2280 "Return the group parameters for GROUP. 2447 "Return the group parameters for GROUP.
2281If SYMBOL, return the value of that symbol in the group parameters." 2448If SYMBOL, return the value of that symbol in the group parameters.
2449Most functions should use `gnus-group-find-parameter', which
2450also examines the topic parameters."
2282 (let ((params (gnus-info-params (gnus-get-info group)))) 2451 (let ((params (gnus-info-params (gnus-get-info group))))
2283 (if symbol 2452 (if symbol
2284 (gnus-group-parameter-value params symbol) 2453 (gnus-group-parameter-value params symbol allow-list)
2285 params))) 2454 params)))
2286 2455
2287(defun gnus-group-parameter-value (params symbol) 2456(defun gnus-group-parameter-value (params symbol &optional allow-list)
2288 "Return the value of SYMBOL in group PARAMS." 2457 "Return the value of SYMBOL in group PARAMS."
2289 (or (car (memq symbol params)) ; It's either a simple symbol 2458 ;; We only wish to return group parameters (dotted lists) and
2290 (cdr (assq symbol params)))) ; or a cons. 2459 ;; not local variables, which may have the same names.
2460 ;; But first we handle single elements...
2461 (or (car (memq symbol params))
2462 ;; Handle alist.
2463 (let (elem)
2464 (catch 'found
2465 (while (setq elem (pop params))
2466 (when (and (consp elem)
2467 (eq (car elem) symbol)
2468 (or allow-list
2469 (atom (cdr elem))))
2470 (throw 'found (cdr elem))))))))
2291 2471
2292(defun gnus-group-add-parameter (group param) 2472(defun gnus-group-add-parameter (group param)
2293 "Add parameter PARAM to GROUP." 2473 "Add parameter PARAM to GROUP."
@@ -2320,7 +2500,7 @@ If SYMBOL, return the value of that symbol in the group parameters."
2320 (when params 2500 (when params
2321 (setq params (delq name params)) 2501 (setq params (delq name params))
2322 (while (assq name params) 2502 (while (assq name params)
2323 (setq params (delq (assq name params) params))) 2503 (gnus-pull name params))
2324 (gnus-info-set-params info params)))))) 2504 (gnus-info-set-params info params))))))
2325 2505
2326(defun gnus-group-add-score (group &optional score) 2506(defun gnus-group-add-score (group &optional score)
@@ -2335,7 +2515,10 @@ If SCORE is nil, add 1 to the score of GROUP."
2335 "Collapse GROUP name LEVELS. 2515 "Collapse GROUP name LEVELS.
2336Select methods are stripped and any remote host name is stripped down to 2516Select methods are stripped and any remote host name is stripped down to
2337just the host name." 2517just the host name."
2338 (let* ((name "") (foreign "") (depth -1) (skip 1) 2518 (let* ((name "")
2519 (foreign "")
2520 (depth 0)
2521 (skip 1)
2339 (levels (or levels 2522 (levels (or levels
2340 (progn 2523 (progn
2341 (while (string-match "\\." group skip) 2524 (while (string-match "\\." group skip)
@@ -2532,11 +2715,14 @@ Disallow illegal group names."
2532(defun gnus-read-method (prompt) 2715(defun gnus-read-method (prompt)
2533 "Prompt the user for a method. 2716 "Prompt the user for a method.
2534Allow completion over sensible values." 2717Allow completion over sensible values."
2535 (let ((method 2718 (let* ((servers
2536 (completing-read 2719 (append gnus-valid-select-methods
2537 prompt (append gnus-valid-select-methods gnus-predefined-server-alist 2720 gnus-predefined-server-alist
2538 gnus-server-alist) 2721 gnus-server-alist))
2539 nil t nil 'gnus-method-history))) 2722 (method
2723 (completing-read
2724 prompt servers
2725 nil t nil 'gnus-method-history)))
2540 (cond 2726 (cond
2541 ((equal method "") 2727 ((equal method "")
2542 (setq method gnus-select-method)) 2728 (setq method gnus-select-method))
@@ -2546,7 +2732,7 @@ Allow completion over sensible values."
2546 (assoc method gnus-valid-select-methods)) 2732 (assoc method gnus-valid-select-methods))
2547 (read-string "Address: ") 2733 (read-string "Address: ")
2548 ""))) 2734 "")))
2549 ((assoc method gnus-server-alist) 2735 ((assoc method servers)
2550 method) 2736 method)
2551 (t 2737 (t
2552 (list (intern method) ""))))) 2738 (list (intern method) "")))))
@@ -2555,7 +2741,7 @@ Allow completion over sensible values."
2555 2741
2556;;;###autoload 2742;;;###autoload
2557(defun gnus-slave-no-server (&optional arg) 2743(defun gnus-slave-no-server (&optional arg)
2558 "Read network news as a slave, without connecting to local server" 2744 "Read network news as a slave, without connecting to local server."
2559 (interactive "P") 2745 (interactive "P")
2560 (gnus-no-server arg t)) 2746 (gnus-no-server arg t))
2561 2747
diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el
index f539a86ed41..7204669fb86 100644
--- a/lisp/gnus/message.el
+++ b/lisp/gnus/message.el
@@ -1,7 +1,7 @@
1;;; message.el --- composing mail and news messages 1;;; message.el --- composing mail and news messages
2;; Copyright (C) 1996,97 Free Software Foundation, Inc. 2;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: mail, news 5;; Keywords: mail, news
6 6
7;; This file is part of GNU Emacs. 7;; This file is part of GNU Emacs.
@@ -31,9 +31,7 @@
31 31
32(eval-when-compile (require 'cl)) 32(eval-when-compile (require 'cl))
33 33
34(require 'sendmail)
35(require 'mailheader) 34(require 'mailheader)
36(require 'rmail)
37(require 'nnheader) 35(require 'nnheader)
38(require 'timezone) 36(require 'timezone)
39(require 'easymenu) 37(require 'easymenu)
@@ -158,8 +156,8 @@ Otherwise, most addresses look like `angles', but they look like
158 :group 'message-headers) 156 :group 'message-headers)
159 157
160(defcustom message-syntax-checks nil 158(defcustom message-syntax-checks nil
161 ;; Guess this one shouldn't be easy to customize... 159 ; Guess this one shouldn't be easy to customize...
162 "Controls what syntax checks should not be performed on outgoing posts. 160 "*Controls what syntax checks should not be performed on outgoing posts.
163To disable checking of long signatures, for instance, add 161To disable checking of long signatures, for instance, add
164 `(signature . disabled)' to this list. 162 `(signature . disabled)' to this list.
165 163
@@ -168,14 +166,14 @@ Don't touch this variable unless you really know what you're doing.
168Checks include subject-cmsg multiple-headers sendsys message-id from 166Checks include subject-cmsg multiple-headers sendsys message-id from
169long-lines control-chars size new-text redirected-followup signature 167long-lines control-chars size new-text redirected-followup signature
170approved sender empty empty-headers message-id from subject 168approved sender empty empty-headers message-id from subject
171shorten-followup-to existing-newsgroups." 169shorten-followup-to existing-newsgroups buffer-file-name unchanged."
172 :group 'message-news) 170 :group 'message-news)
173 171
174(defcustom message-required-news-headers 172(defcustom message-required-news-headers
175 '(From Newsgroups Subject Date Message-ID 173 '(From Newsgroups Subject Date Message-ID
176 (optional . Organization) Lines 174 (optional . Organization) Lines
177 (optional . X-Newsreader)) 175 (optional . X-Newsreader))
178 "Headers to be generated or prompted for when posting an article. 176 "*Headers to be generated or prompted for when posting an article.
179RFC977 and RFC1036 require From, Date, Newsgroups, Subject, 177RFC977 and RFC1036 require From, Date, Newsgroups, Subject,
180Message-ID. Organization, Lines, In-Reply-To, Expires, and 178Message-ID. Organization, Lines, In-Reply-To, Expires, and
181X-Newsreader are optional. If don't you want message to insert some 179X-Newsreader are optional. If don't you want message to insert some
@@ -187,7 +185,7 @@ header, remove it from this list."
187(defcustom message-required-mail-headers 185(defcustom message-required-mail-headers
188 '(From Subject Date (optional . In-Reply-To) Message-ID Lines 186 '(From Subject Date (optional . In-Reply-To) Message-ID Lines
189 (optional . X-Mailer)) 187 (optional . X-Mailer))
190 "Headers to be generated or prompted for when mailing a message. 188 "*Headers to be generated or prompted for when mailing a message.
191RFC822 required that From, Date, To, Subject and Message-ID be 189RFC822 required that From, Date, To, Subject and Message-ID be
192included. Organization, Lines and X-Mailer are optional." 190included. Organization, Lines and X-Mailer are optional."
193 :group 'message-mail 191 :group 'message-mail
@@ -200,13 +198,13 @@ included. Organization, Lines and X-Mailer are optional."
200 :type 'sexp) 198 :type 'sexp)
201 199
202(defcustom message-ignored-news-headers 200(defcustom message-ignored-news-headers
203 "^NNTP-Posting-Host:\\|^Xref:\\|^Bcc:\\|^Gcc:\\|^Fcc:\\|^Resent-Fcc:" 201 "^NNTP-Posting-Host:\\|^Xref:\\|^[BGF]cc:\\|^Resent-Fcc:"
204 "*Regexp of headers to be removed unconditionally before posting." 202 "*Regexp of headers to be removed unconditionally before posting."
205 :group 'message-news 203 :group 'message-news
206 :group 'message-headers 204 :group 'message-headers
207 :type 'regexp) 205 :type 'regexp)
208 206
209(defcustom message-ignored-mail-headers "^Gcc:\\|^Fcc:\\|^Resent-Fcc:" 207(defcustom message-ignored-mail-headers "^[GF]cc:\\|^Resent-Fcc:\\|^Xref:"
210 "*Regexp of headers to be removed unconditionally before mailing." 208 "*Regexp of headers to be removed unconditionally before mailing."
211 :group 'message-mail 209 :group 'message-mail
212 :group 'message-headers 210 :group 'message-headers
@@ -219,6 +217,11 @@ any confusion."
219 :group 'message-interface 217 :group 'message-interface
220 :type 'regexp) 218 :type 'regexp)
221 219
220(defcustom message-subject-re-regexp "^[ \t]*\\([Rr][Ee]:[ \t]*\\)*[ \t]*"
221 "*Regexp matching \"Re: \" in the subject line."
222 :group 'message-various
223 :type 'regexp)
224
222;;;###autoload 225;;;###autoload
223(defcustom message-signature-separator "^-- *$" 226(defcustom message-signature-separator "^-- *$"
224 "Regexp matching the signature separator." 227 "Regexp matching the signature separator."
@@ -226,7 +229,9 @@ any confusion."
226 :group 'message-various) 229 :group 'message-various)
227 230
228(defcustom message-elide-elipsis "\n[...]\n\n" 231(defcustom message-elide-elipsis "\n[...]\n\n"
229 "*The string which is inserted for elided text.") 232 "*The string which is inserted for elided text."
233 :type 'string
234 :group 'message-various)
230 235
231(defcustom message-interactive nil 236(defcustom message-interactive nil
232 "Non-nil means when sending a message wait for and display errors. 237 "Non-nil means when sending a message wait for and display errors.
@@ -236,7 +241,7 @@ nil means let mailer mail back a message to report errors."
236 :type 'boolean) 241 :type 'boolean)
237 242
238(defcustom message-generate-new-buffers t 243(defcustom message-generate-new-buffers t
239 "*Non-nil means that a new message buffer will be created whenever `mail-setup' is called. 244 "*Non-nil means that a new message buffer will be created whenever `message-setup' is called.
240If this is a function, call that function with three parameters: The type, 245If this is a function, call that function with three parameters: The type,
241the to address and the group name. (Any of these may be nil.) The function 246the to address and the group name. (Any of these may be nil.) The function
242should return the new buffer name." 247should return the new buffer name."
@@ -269,13 +274,6 @@ If t, use `message-user-organization-file'."
269 :type 'file 274 :type 'file
270 :group 'message-headers) 275 :group 'message-headers)
271 276
272(defcustom message-auto-save-directory "~/"
273 ; (concat (file-name-as-directory message-directory) "drafts/")
274 "*Directory where message auto-saves buffers.
275If nil, message won't auto-save."
276 :group 'message-buffers
277 :type 'directory)
278
279(defcustom message-forward-start-separator 277(defcustom message-forward-start-separator
280 "------- Start of forwarded message -------\n" 278 "------- Start of forwarded message -------\n"
281 "*Delimiter inserted before forwarded messages." 279 "*Delimiter inserted before forwarded messages."
@@ -294,11 +292,32 @@ If nil, message won't auto-save."
294 :type 'boolean) 292 :type 'boolean)
295 293
296(defcustom message-included-forward-headers 294(defcustom message-included-forward-headers
297 "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-\\|^Message-ID:\\|^References:" 295 "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-\\|^Message-ID:\\|^References:\\|^Content-Transfer-Encoding:\\|^Content-Type:\\|^Mime-Version:"
298 "*Regexp matching headers to be included in forwarded messages." 296 "*Regexp matching headers to be included in forwarded messages."
299 :group 'message-forwarding 297 :group 'message-forwarding
300 :type 'regexp) 298 :type 'regexp)
301 299
300(defcustom message-make-forward-subject-function
301 'message-forward-subject-author-subject
302 "*A list of functions that are called to generate a subject header for forwarded messages.
303The subject generated by the previous function is passed into each
304successive function.
305
306The provided functions are:
307
308* message-forward-subject-author-subject (Source of article (author or
309 newsgroup)), in brackets followed by the subject
310* message-forward-subject-fwd (Subject of article with 'Fwd:' prepended
311 to it."
312 :group 'message-forwarding
313 :type '(radio (function-item message-forward-subject-author-subject)
314 (function-item message-forward-subject-fwd)))
315
316(defcustom message-wash-forwarded-subjects nil
317 "*If non-nil, try to remove as much old cruft as possible from the subject of messages before generating the new subject of a forward."
318 :group 'message-forwarding
319 :type 'boolean)
320
302(defcustom message-ignored-resent-headers "^Return-receipt" 321(defcustom message-ignored-resent-headers "^Return-receipt"
303 "*All headers that match this regexp will be deleted when resending a message." 322 "*All headers that match this regexp will be deleted when resending a message."
304 :group 'message-interface 323 :group 'message-interface
@@ -322,10 +341,12 @@ The headers should be delimited by a line whose contents match the
322variable `mail-header-separator'. 341variable `mail-header-separator'.
323 342
324Legal values include `message-send-mail-with-sendmail' (the default), 343Legal values include `message-send-mail-with-sendmail' (the default),
325`message-send-mail-with-mh' and `message-send-mail-with-qmail'." 344`message-send-mail-with-mh', `message-send-mail-with-qmail' and
345`smtpmail-send-it'."
326 :type '(radio (function-item message-send-mail-with-sendmail) 346 :type '(radio (function-item message-send-mail-with-sendmail)
327 (function-item message-send-mail-with-mh) 347 (function-item message-send-mail-with-mh)
328 (function-item message-send-mail-with-qmail) 348 (function-item message-send-mail-with-qmail)
349 (function-item smtpmail-send-it)
329 (function :tag "Other")) 350 (function :tag "Other"))
330 :group 'message-sending 351 :group 'message-sending
331 :group 'message-mail) 352 :group 'message-mail)
@@ -397,12 +418,15 @@ might set this variable to '(\"-f\" \"you@some.where\")."
397(defvar gnus-select-method) 418(defvar gnus-select-method)
398(defcustom message-post-method 419(defcustom message-post-method
399 (cond ((and (boundp 'gnus-post-method) 420 (cond ((and (boundp 'gnus-post-method)
421 (listp gnus-post-method)
400 gnus-post-method) 422 gnus-post-method)
401 gnus-post-method) 423 gnus-post-method)
402 ((boundp 'gnus-select-method) 424 ((boundp 'gnus-select-method)
403 gnus-select-method) 425 gnus-select-method)
404 (t '(nnspool ""))) 426 (t '(nnspool "")))
405 "Method used to post news." 427 "*Method used to post news.
428Note that when posting from inside Gnus, for instance, this
429variable isn't used."
406 :group 'message-news 430 :group 'message-news
407 :group 'message-sending 431 :group 'message-sending
408 ;; This should be the `gnus-select-method' widget, but that might 432 ;; This should be the `gnus-select-method' widget, but that might
@@ -438,8 +462,7 @@ the signature is inserted."
438 :type 'hook) 462 :type 'hook)
439 463
440(defcustom message-header-setup-hook nil 464(defcustom message-header-setup-hook nil
441 "Hook called narrowed to the headers when setting up a message 465 "Hook called narrowed to the headers when setting up a message buffer."
442buffer."
443 :group 'message-various 466 :group 'message-various
444 :type 'hook) 467 :type 'hook)
445 468
@@ -463,12 +486,11 @@ Used by `message-yank-original' via `message-yank-cite'."
463 :type 'integer) 486 :type 'integer)
464 487
465;;;###autoload 488;;;###autoload
466(defcustom message-cite-function 489(defcustom message-cite-function 'message-cite-original
467 'message-cite-original
468 "*Function for citing an original message. 490 "*Function for citing an original message.
469Predefined functions include `message-cite-original' and 491Predefined functions include `message-cite-original' and
470`message-cite-original-without-signature'. 492`message-cite-original-without-signature'.
471Note that `message-cite-original' uses `mail-citation-hook'if that is non-nil." 493Note that `message-cite-original' uses `mail-citation-hook' if that is non-nil."
472 :type '(radio (function-item message-cite-original) 494 :type '(radio (function-item message-cite-original)
473 (function-item sc-cite-original) 495 (function-item sc-cite-original)
474 (function :tag "Other")) 496 (function :tag "Other"))
@@ -538,25 +560,31 @@ If stringp, use this; if non-nil, use no host name (user name only)."
538(defvar message-postpone-actions nil 560(defvar message-postpone-actions nil
539 "A list of actions to be performed after postponing a message.") 561 "A list of actions to be performed after postponing a message.")
540 562
563(define-widget 'message-header-lines 'text
564 "All header lines must be LFD terminated."
565 :format "%t:%n%v"
566 :valid-regexp "^\\'"
567 :error "All header lines must be newline terminated")
568
541(defcustom message-default-headers "" 569(defcustom message-default-headers ""
542 "*A string containing header lines to be inserted in outgoing messages. 570 "*A string containing header lines to be inserted in outgoing messages.
543It is inserted before you edit the message, so you can edit or delete 571It is inserted before you edit the message, so you can edit or delete
544these lines." 572these lines."
545 :group 'message-headers 573 :group 'message-headers
546 :type 'string) 574 :type 'message-header-lines)
547 575
548(defcustom message-default-mail-headers "" 576(defcustom message-default-mail-headers ""
549 "*A string of header lines to be inserted in outgoing mails." 577 "*A string of header lines to be inserted in outgoing mails."
550 :group 'message-headers 578 :group 'message-headers
551 :group 'message-mail 579 :group 'message-mail
552 :type 'string) 580 :type 'message-header-lines)
553 581
554(defcustom message-default-news-headers "" 582(defcustom message-default-news-headers ""
555 "*A string of header lines to be inserted in outgoing news 583 "*A string of header lines to be inserted in outgoing news
556articles." 584articles."
557 :group 'message-headers 585 :group 'message-headers
558 :group 'message-news 586 :group 'message-news
559 :type 'string) 587 :type 'message-header-lines)
560 588
561;; Note: could use /usr/ucb/mail instead of sendmail; 589;; Note: could use /usr/ucb/mail instead of sendmail;
562;; options -t, and -v if not interactive. 590;; options -t, and -v if not interactive.
@@ -578,7 +606,7 @@ articles."
578 ;; 33 and 126, except colon)", i. e., any chars except ctl chars, 606 ;; 33 and 126, except colon)", i. e., any chars except ctl chars,
579 ;; space, or colon. 607 ;; space, or colon.
580 '(looking-at "[ \t]\\|[][!\"#$%&'()*+,-./0-9;<=>?@A-Z\\\\^_`a-z{|}~]+:")) 608 '(looking-at "[ \t]\\|[][!\"#$%&'()*+,-./0-9;<=>?@A-Z\\\\^_`a-z{|}~]+:"))
581 "Set this non-nil if the system's mailer runs the header and body together. 609 "*Set this non-nil if the system's mailer runs the header and body together.
582\(This problem exists on Sunos 4 when sendmail is run in remote mode.) 610\(This problem exists on Sunos 4 when sendmail is run in remote mode.)
583The value should be an expression to test whether the problem will 611The value should be an expression to test whether the problem will
584actually occur." 612actually occur."
@@ -616,6 +644,13 @@ the prefix.")
616The default is `abbrev', which uses mailabbrev. nil switches 644The default is `abbrev', which uses mailabbrev. nil switches
617mail aliases off.") 645mail aliases off.")
618 646
647(defcustom message-auto-save-directory
648 (nnheader-concat message-directory "drafts/")
649 "*Directory where Message auto-saves buffers if Gnus isn't running.
650If nil, Message won't auto-save."
651 :group 'message-buffers
652 :type 'directory)
653
619;;; Internal variables. 654;;; Internal variables.
620;;; Well, not really internal. 655;;; Well, not really internal.
621 656
@@ -684,7 +719,7 @@ Defaults to `text-mode-abbrev-table'.")
684(defface message-header-other-face 719(defface message-header-other-face
685 '((((class color) 720 '((((class color)
686 (background dark)) 721 (background dark))
687 (:foreground "red4")) 722 (:foreground "#b00000"))
688 (((class color) 723 (((class color)
689 (background light)) 724 (background light))
690 (:foreground "steel blue")) 725 (:foreground "steel blue"))
@@ -720,7 +755,7 @@ Defaults to `text-mode-abbrev-table'.")
720(defface message-separator-face 755(defface message-separator-face
721 '((((class color) 756 '((((class color)
722 (background dark)) 757 (background dark))
723 (:foreground "blue4")) 758 (:foreground "blue3"))
724 (((class color) 759 (((class color)
725 (background light)) 760 (background light))
726 (:foreground "brown")) 761 (:foreground "brown"))
@@ -763,14 +798,21 @@ Defaults to `text-mode-abbrev-table'.")
763 (,(concat "^\\(X-[A-Za-z0-9-]+\\|In-Reply-To\\):" content) 798 (,(concat "^\\(X-[A-Za-z0-9-]+\\|In-Reply-To\\):" content)
764 (1 'message-header-name-face) 799 (1 'message-header-name-face)
765 (2 'message-header-name-face)) 800 (2 'message-header-name-face))
766 (,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$") 801 ,@(if (and mail-header-separator
767 1 'message-separator-face) 802 (not (equal mail-header-separator "")))
803 `((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$")
804 1 'message-separator-face))
805 nil)
768 (,(concat "^[ \t]*" 806 (,(concat "^[ \t]*"
769 "\\([" cite-prefix "]+[" cite-suffix "]*\\)?" 807 "\\([" cite-prefix "]+[" cite-suffix "]*\\)?"
770 "[>|}].*") 808 "[:>|}].*")
771 (0 'message-cited-text-face)))) 809 (0 'message-cited-text-face))))
772 "Additional expressions to highlight in Message mode.") 810 "Additional expressions to highlight in Message mode.")
773 811
812;; XEmacs does it like this. For Emacs, we have to set the
813;; `font-lock-defaults' buffer-local variable.
814(put 'message-mode 'font-lock-defaults '(message-font-lock-keywords t))
815
774(defvar message-face-alist 816(defvar message-face-alist
775 '((bold . bold-region) 817 '((bold . bold-region)
776 (underline . underline-region) 818 (underline . underline-region)
@@ -801,11 +843,15 @@ The cdr of ech entry is a function for applying the face to a region.")
801 :group 'message-various 843 :group 'message-various
802 :type 'hook) 844 :type 'hook)
803 845
846(defvar message-send-coding-system 'binary
847 "Coding system to encode outgoing mail.")
848
804;;; Internal variables. 849;;; Internal variables.
805 850
806(defvar message-buffer-list nil) 851(defvar message-buffer-list nil)
807(defvar message-this-is-news nil) 852(defvar message-this-is-news nil)
808(defvar message-this-is-mail nil) 853(defvar message-this-is-mail nil)
854(defvar message-draft-article nil)
809 855
810;; Byte-compiler warning 856;; Byte-compiler warning
811(defvar gnus-active-hashtb) 857(defvar gnus-active-hashtb)
@@ -864,7 +910,7 @@ The cdr of ech entry is a function for applying the face to a region.")
864 "\\(remote from .*\\)?" 910 "\\(remote from .*\\)?"
865 911
866 "\n")) 912 "\n"))
867 nil) 913 "Regexp matching the delimiter of messages in UNIX mail format.")
868 914
869(defvar message-unsent-separator 915(defvar message-unsent-separator
870 (concat "^ *---+ +Unsent message follows +---+ *$\\|" 916 (concat "^ *---+ +Unsent message follows +---+ *$\\|"
@@ -890,19 +936,26 @@ The cdr of ech entry is a function for applying the face to a region.")
890 (Lines) 936 (Lines)
891 (Expires) 937 (Expires)
892 (Message-ID) 938 (Message-ID)
893 (References) 939 (References . message-shorten-references)
894 (X-Mailer) 940 (X-Mailer)
895 (X-Newsreader)) 941 (X-Newsreader))
896 "Alist used for formatting headers.") 942 "Alist used for formatting headers.")
897 943
898(eval-and-compile 944(eval-and-compile
899 (autoload 'message-setup-toolbar "messagexmas") 945 (autoload 'message-setup-toolbar "messagexmas")
946 (autoload 'mh-new-draft-name "mh-comp")
900 (autoload 'mh-send-letter "mh-comp") 947 (autoload 'mh-send-letter "mh-comp")
901 (autoload 'gnus-point-at-eol "gnus-util") 948 (autoload 'gnus-point-at-eol "gnus-util")
902 (autoload 'gnus-point-at-bol "gnus-util") 949 (autoload 'gnus-point-at-bol "gnus-util")
903 (autoload 'gnus-output-to-mail "gnus-util") 950 (autoload 'gnus-output-to-mail "gnus-util")
904 (autoload 'gnus-output-to-rmail "gnus-util") 951 (autoload 'gnus-output-to-rmail "gnus-util")
905 (autoload 'mail-abbrev-in-expansion-header-p "mailabbrev")) 952 (autoload 'mail-abbrev-in-expansion-header-p "mailabbrev")
953 (autoload 'nndraft-request-associate-buffer "nndraft")
954 (autoload 'nndraft-request-expire-articles "nndraft")
955 (autoload 'gnus-open-server "gnus-int")
956 (autoload 'gnus-request-post "gnus-int")
957 (autoload 'gnus-alive-p "gnus-util")
958 (autoload 'rmail-output "rmail"))
906 959
907 960
908 961
@@ -965,7 +1018,8 @@ The cdr of ech entry is a function for applying the face to a region.")
965 1018
966(defun message-fetch-field (header &optional not-all) 1019(defun message-fetch-field (header &optional not-all)
967 "The same as `mail-fetch-field', only remove all newlines." 1020 "The same as `mail-fetch-field', only remove all newlines."
968 (let ((value (mail-fetch-field header nil (not not-all)))) 1021 (let* ((inhibit-point-motion-hooks t)
1022 (value (mail-fetch-field header nil (not not-all))))
969 (when value 1023 (when value
970 (nnheader-replace-chars-in-string value ?\n ? )))) 1024 (nnheader-replace-chars-in-string value ?\n ? ))))
971 1025
@@ -1003,11 +1057,11 @@ The cdr of ech entry is a function for applying the face to a region.")
1003 "Return non-nil if FORM is funcallable." 1057 "Return non-nil if FORM is funcallable."
1004 (or (and (symbolp form) (fboundp form)) 1058 (or (and (symbolp form) (fboundp form))
1005 (and (listp form) (eq (car form) 'lambda)) 1059 (and (listp form) (eq (car form) 'lambda))
1006 (compiled-function-p form))) 1060 (byte-code-function-p form)))
1007 1061
1008(defun message-strip-subject-re (subject) 1062(defun message-strip-subject-re (subject)
1009 "Remove \"Re:\" from subject lines." 1063 "Remove \"Re:\" from subject lines."
1010 (if (string-match "^[Rr][Ee]: *" subject) 1064 (if (string-match message-subject-re-regexp subject)
1011 (substring subject (match-end 0)) 1065 (substring subject (match-end 0))
1012 subject)) 1066 subject))
1013 1067
@@ -1017,7 +1071,7 @@ If REGEXP, HEADER is a regular expression.
1017If FIRST, only remove the first instance of the header. 1071If FIRST, only remove the first instance of the header.
1018Return the number of headers removed." 1072Return the number of headers removed."
1019 (goto-char (point-min)) 1073 (goto-char (point-min))
1020 (let ((regexp (if is-regexp header (concat "^" header ":"))) 1074 (let ((regexp (if is-regexp header (concat "^" (regexp-quote header) ":")))
1021 (number 0) 1075 (number 0)
1022 (case-fold-search t) 1076 (case-fold-search t)
1023 last) 1077 last)
@@ -1068,21 +1122,24 @@ Return the number of headers removed."
1068 1122
1069(defun message-news-p () 1123(defun message-news-p ()
1070 "Say whether the current buffer contains a news message." 1124 "Say whether the current buffer contains a news message."
1071 (or message-this-is-news 1125 (and (not message-this-is-mail)
1072 (save-excursion 1126 (or message-this-is-news
1073 (save-restriction 1127 (save-excursion
1074 (message-narrow-to-headers) 1128 (save-restriction
1075 (message-fetch-field "newsgroups"))))) 1129 (message-narrow-to-headers)
1130 (and (message-fetch-field "newsgroups")
1131 (not (message-fetch-field "posted-to"))))))))
1076 1132
1077(defun message-mail-p () 1133(defun message-mail-p ()
1078 "Say whether the current buffer contains a mail message." 1134 "Say whether the current buffer contains a mail message."
1079 (or message-this-is-mail 1135 (and (not message-this-is-news)
1080 (save-excursion 1136 (or message-this-is-mail
1081 (save-restriction 1137 (save-excursion
1082 (message-narrow-to-headers) 1138 (save-restriction
1083 (or (message-fetch-field "to") 1139 (message-narrow-to-headers)
1084 (message-fetch-field "cc") 1140 (or (message-fetch-field "to")
1085 (message-fetch-field "bcc")))))) 1141 (message-fetch-field "cc")
1142 (message-fetch-field "bcc")))))))
1086 1143
1087(defun message-next-header () 1144(defun message-next-header ()
1088 "Go to the beginning of the next header." 1145 "Go to the beginning of the next header."
@@ -1170,6 +1227,9 @@ Return the number of headers removed."
1170 (define-key message-mode-map "\C-c\C-d" 'message-dont-send) 1227 (define-key message-mode-map "\C-c\C-d" 'message-dont-send)
1171 1228
1172 (define-key message-mode-map "\C-c\C-e" 'message-elide-region) 1229 (define-key message-mode-map "\C-c\C-e" 'message-elide-region)
1230 (define-key message-mode-map "\C-c\C-v" 'message-delete-not-region)
1231 (define-key message-mode-map "\C-c\C-z" 'message-kill-to-signature)
1232 (define-key message-mode-map "\M-\r" 'message-newline-and-reformat)
1173 1233
1174 (define-key message-mode-map "\t" 'message-tab)) 1234 (define-key message-mode-map "\t" 'message-tab))
1175 1235
@@ -1183,11 +1243,15 @@ Return the number of headers removed."
1183 ["Caesar (rot13) Message" message-caesar-buffer-body t] 1243 ["Caesar (rot13) Message" message-caesar-buffer-body t]
1184 ["Caesar (rot13) Region" message-caesar-region (mark t)] 1244 ["Caesar (rot13) Region" message-caesar-region (mark t)]
1185 ["Elide Region" message-elide-region (mark t)] 1245 ["Elide Region" message-elide-region (mark t)]
1246 ["Delete Outside Region" message-delete-not-region (mark t)]
1247 ["Kill To Signature" message-kill-to-signature t]
1248 ["Newline and Reformat" message-newline-and-reformat t]
1186 ["Rename buffer" message-rename-buffer t] 1249 ["Rename buffer" message-rename-buffer t]
1187 ["Spellcheck" ispell-message t] 1250 ["Spellcheck" ispell-message t]
1188 "----" 1251 "----"
1189 ["Send Message" message-send-and-exit t] 1252 ["Send Message" message-send-and-exit t]
1190 ["Abort Message" message-dont-send t])) 1253 ["Abort Message" message-dont-send t]
1254 ["Kill Message" message-kill-buffer t]))
1191 1255
1192(easy-menu-define 1256(easy-menu-define
1193 message-mode-field-menu message-mode-map "" 1257 message-mode-field-menu message-mode-map ""
@@ -1230,23 +1294,24 @@ C-c C-w message-insert-signature (insert `message-signature-file' file).
1230C-c C-y message-yank-original (insert current message, if any). 1294C-c C-y message-yank-original (insert current message, if any).
1231C-c C-q message-fill-yanked-message (fill what was yanked). 1295C-c C-q message-fill-yanked-message (fill what was yanked).
1232C-c C-e message-elide-region (elide the text between point and mark). 1296C-c C-e message-elide-region (elide the text between point and mark).
1297C-c C-z message-kill-to-signature (kill the text up to the signature).
1233C-c C-r message-caesar-buffer-body (rot13 the message body)." 1298C-c C-r message-caesar-buffer-body (rot13 the message body)."
1234 (interactive) 1299 (interactive)
1235 (kill-all-local-variables) 1300 (kill-all-local-variables)
1236 (make-local-variable 'message-reply-buffer) 1301 (make-local-variable 'message-reply-buffer)
1237 (setq message-reply-buffer nil) 1302 (setq message-reply-buffer nil)
1238 (make-local-variable 'message-send-actions) 1303 (make-local-variable 'message-send-actions)
1239 (make-local-variable 'message-exit-actions) 1304 (make-local-variable 'message-exit-actions)
1240 (make-local-variable 'message-kill-actions) 1305 (make-local-variable 'message-kill-actions)
1241 (make-local-variable 'message-postpone-actions) 1306 (make-local-variable 'message-postpone-actions)
1307 (make-local-variable 'message-draft-article)
1308 (make-local-hook 'kill-buffer-hook)
1242 (set-syntax-table message-mode-syntax-table) 1309 (set-syntax-table message-mode-syntax-table)
1243 (use-local-map message-mode-map) 1310 (use-local-map message-mode-map)
1244 (setq local-abbrev-table message-mode-abbrev-table) 1311 (setq local-abbrev-table message-mode-abbrev-table)
1245 (setq major-mode 'message-mode) 1312 (setq major-mode 'message-mode)
1246 (setq mode-name "Message") 1313 (setq mode-name "Message")
1247 (setq buffer-offer-save t) 1314 (setq buffer-offer-save t)
1248 (make-local-variable 'font-lock-defaults)
1249 (setq font-lock-defaults '(message-font-lock-keywords t))
1250 (make-local-variable 'facemenu-add-face-function) 1315 (make-local-variable 'facemenu-add-face-function)
1251 (make-local-variable 'facemenu-remove-face-function) 1316 (make-local-variable 'facemenu-remove-face-function)
1252 (setq facemenu-add-face-function 1317 (setq facemenu-add-face-function
@@ -1264,9 +1329,9 @@ C-c C-r message-caesar-buffer-body (rot13 the message body)."
1264 ;; Lines containing just >= 3 dashes, perhaps after whitespace, 1329 ;; Lines containing just >= 3 dashes, perhaps after whitespace,
1265 ;; are also sometimes used and should be separators. 1330 ;; are also sometimes used and should be separators.
1266 (setq paragraph-start (concat (regexp-quote mail-header-separator) 1331 (setq paragraph-start (concat (regexp-quote mail-header-separator)
1267 "$\\|[ \t]*[a-z0-9A-Z]*>+[ \t]*$\\|[ \t]*$\\|" 1332 "$\\|[ \t]*[a-z0-9A-Z]*>+[ \t]*$\\|[ \t]*$\\|"
1268 "-- $\\|---+$\\|" 1333 "-- $\\|---+$\\|"
1269 page-delimiter)) 1334 page-delimiter))
1270 (setq paragraph-separate paragraph-start) 1335 (setq paragraph-separate paragraph-start)
1271 (make-local-variable 'message-reply-headers) 1336 (make-local-variable 'message-reply-headers)
1272 (setq message-reply-headers nil) 1337 (setq message-reply-headers nil)
@@ -1294,7 +1359,20 @@ C-c C-r message-caesar-buffer-body (rot13 the message body)."
1294 (when (eq message-mail-alias-type 'abbrev) 1359 (when (eq message-mail-alias-type 'abbrev)
1295 (if (fboundp 'mail-abbrevs-setup) 1360 (if (fboundp 'mail-abbrevs-setup)
1296 (mail-abbrevs-setup) 1361 (mail-abbrevs-setup)
1297 (funcall (intern "mail-aliases-setup")))) 1362 (mail-aliases-setup)))
1363 (message-set-auto-save-file-name)
1364 (unless (string-match "XEmacs" emacs-version)
1365 (set (make-local-variable 'font-lock-defaults)
1366 '(message-font-lock-keywords t)))
1367 (make-local-variable 'adaptive-fill-regexp)
1368 (setq adaptive-fill-regexp
1369 (concat "[ \t]*[-a-z0-9A-Z]*>+[ \t]*\\|" adaptive-fill-regexp))
1370 (unless (boundp 'adaptive-fill-first-line-regexp)
1371 (setq adaptive-fill-first-line-regexp nil))
1372 (make-local-variable 'adaptive-fill-first-line-regexp)
1373 (setq adaptive-fill-first-line-regexp
1374 (concat "[ \t]*[-a-z0-9A-Z]*>+[ \t]*\\|"
1375 adaptive-fill-first-line-regexp))
1298 (run-hooks 'text-mode-hook 'message-mode-hook)) 1376 (run-hooks 'text-mode-hook 'message-mode-hook))
1299 1377
1300 1378
@@ -1367,13 +1445,22 @@ C-c C-r message-caesar-buffer-body (rot13 the message body)."
1367 (goto-char (point-min)) 1445 (goto-char (point-min))
1368 (search-forward (concat "\n" mail-header-separator "\n") nil t)) 1446 (search-forward (concat "\n" mail-header-separator "\n") nil t))
1369 1447
1448(defun message-goto-eoh ()
1449 "Move point to the end of the headers."
1450 (interactive)
1451 (message-goto-body)
1452 (forward-line -2))
1453
1370(defun message-goto-signature () 1454(defun message-goto-signature ()
1371 "Move point to the beginning of the message signature." 1455 "Move point to the beginning of the message signature.
1456If there is no signature in the article, go to the end and
1457return nil."
1372 (interactive) 1458 (interactive)
1373 (goto-char (point-min)) 1459 (goto-char (point-min))
1374 (if (re-search-forward message-signature-separator nil t) 1460 (if (re-search-forward message-signature-separator nil t)
1375 (forward-line 1) 1461 (forward-line 1)
1376 (goto-char (point-max)))) 1462 (goto-char (point-max))
1463 nil))
1377 1464
1378 1465
1379 1466
@@ -1408,6 +1495,49 @@ With the prefix argument FORCE, insert the header anyway."
1408 1495
1409;;; Various commands 1496;;; Various commands
1410 1497
1498(defun message-delete-not-region (beg end)
1499 "Delete everything in the body of the current message that is outside of the region."
1500 (interactive "r")
1501 (save-excursion
1502 (goto-char end)
1503 (delete-region (point) (if (not (message-goto-signature))
1504 (point)
1505 (forward-line -2)
1506 (point)))
1507 (insert "\n")
1508 (goto-char beg)
1509 (delete-region beg (progn (message-goto-body)
1510 (forward-line 2)
1511 (point))))
1512 (when (message-goto-signature)
1513 (forward-line -2)))
1514
1515(defun message-kill-to-signature ()
1516 "Deletes all text up to the signature."
1517 (interactive)
1518 (let ((point (point)))
1519 (message-goto-signature)
1520 (unless (eobp)
1521 (forward-line -2))
1522 (kill-region point (point))
1523 (unless (bolp)
1524 (insert "\n"))))
1525
1526(defun message-newline-and-reformat ()
1527 "Insert four newlines, and then reformat if inside quoted text."
1528 (interactive)
1529 (let ((point (point))
1530 quoted)
1531 (save-excursion
1532 (beginning-of-line)
1533 (setq quoted (looking-at (regexp-quote message-yank-prefix))))
1534 (insert "\n\n\n\n")
1535 (when quoted
1536 (insert message-yank-prefix))
1537 (fill-paragraph nil)
1538 (goto-char point)
1539 (forward-line 2)))
1540
1411(defun message-insert-signature (&optional force) 1541(defun message-insert-signature (&optional force)
1412 "Insert a signature. See documentation for the `message-signature' variable." 1542 "Insert a signature. See documentation for the `message-signature' variable."
1413 (interactive (list 0)) 1543 (interactive (list 0))
@@ -1447,8 +1577,9 @@ With the prefix argument FORCE, insert the header anyway."
1447 (or (bolp) (insert "\n"))))) 1577 (or (bolp) (insert "\n")))))
1448 1578
1449(defun message-elide-region (b e) 1579(defun message-elide-region (b e)
1450 "Elide the text between point and mark. An ellipsis (from 1580 "Elide the text between point and mark.
1451message-elide-elipsis) will be inserted where the text was killed." 1581An ellipsis (from `message-elide-elipsis') will be inserted where the
1582text was killed."
1452 (interactive "r") 1583 (interactive "r")
1453 (kill-region b e) 1584 (kill-region b e)
1454 (unless (bolp) 1585 (unless (bolp)
@@ -1499,7 +1630,7 @@ message-elide-elipsis) will be inserted where the text was killed."
1499 1630
1500(defun message-caesar-buffer-body (&optional rotnum) 1631(defun message-caesar-buffer-body (&optional rotnum)
1501 "Caesar rotates all letters in the current buffer by 13 places. 1632 "Caesar rotates all letters in the current buffer by 13 places.
1502Used to encode/decode possibly offensive messages (commonly in net.jokes). 1633Used to encode/decode possiblyun offensive messages (commonly in net.jokes).
1503With prefix arg, specifies the number of places to rotate each letter forward. 1634With prefix arg, specifies the number of places to rotate each letter forward.
1504Mail and USENET news headers are not rotated." 1635Mail and USENET news headers are not rotated."
1505 (interactive (if current-prefix-arg 1636 (interactive (if current-prefix-arg
@@ -1544,9 +1675,7 @@ name, rather than giving an automatic name."
1544 (name-default (concat "*message* " mail-trimmed-to)) 1675 (name-default (concat "*message* " mail-trimmed-to))
1545 (name (if enter-string 1676 (name (if enter-string
1546 (read-string "New buffer name: " name-default) 1677 (read-string "New buffer name: " name-default)
1547 name-default)) 1678 name-default)))
1548 (default-directory
1549 (file-name-as-directory message-auto-save-directory)))
1550 (rename-buffer name t))))) 1679 (rename-buffer name t)))))
1551 1680
1552(defun message-fill-yanked-message (&optional justifyp) 1681(defun message-fill-yanked-message (&optional justifyp)
@@ -1627,26 +1756,52 @@ prefix, and don't delete any headers."
1627 (unless (bolp) 1756 (unless (bolp)
1628 (insert ?\n)) 1757 (insert ?\n))
1629 (unless modified 1758 (unless modified
1630 (setq message-checksum (cons (message-checksum) (buffer-size))))))) 1759 (setq message-checksum (message-checksum))))))
1631 1760
1761(defun message-cite-original-without-signature ()
1762 "Cite function in the standard Message manner."
1763 (let ((start (point))
1764 (end (mark t))
1765 (functions
1766 (when message-indent-citation-function
1767 (if (listp message-indent-citation-function)
1768 message-indent-citation-function
1769 (list message-indent-citation-function)))))
1770 (goto-char end)
1771 (when (re-search-backward "^-- $" start t)
1772 ;; Also peel off any blank lines before the signature.
1773 (forward-line -1)
1774 (while (looking-at "^[ \t]*$")
1775 (forward-line -1))
1776 (forward-line 1)
1777 (delete-region (point) end))
1778 (goto-char start)
1779 (while functions
1780 (funcall (pop functions)))
1781 (when message-citation-line-function
1782 (unless (bolp)
1783 (insert "\n"))
1784 (funcall message-citation-line-function))))
1785
1786(defvar mail-citation-hook) ;Compiler directive
1632(defun message-cite-original () 1787(defun message-cite-original ()
1633 "Cite function in the standard Message manner." 1788 "Cite function in the standard Message manner."
1634 (if (and (boundp 'mail-citation-hook) 1789 (if (and (boundp 'mail-citation-hook)
1635 mail-citation-hook) 1790 mail-citation-hook)
1636 (run-hooks 'mail-citation-hook) 1791 (run-hooks 'mail-citation-hook)
1637 (let ((start (point)) 1792 (let ((start (point))
1638 (functions 1793 (functions
1639 (when message-indent-citation-function 1794 (when message-indent-citation-function
1640 (if (listp message-indent-citation-function) 1795 (if (listp message-indent-citation-function)
1641 message-indent-citation-function 1796 message-indent-citation-function
1642 (list message-indent-citation-function))))) 1797 (list message-indent-citation-function)))))
1643 (goto-char start) 1798 (goto-char start)
1644 (while functions 1799 (while functions
1645 (funcall (pop functions))) 1800 (funcall (pop functions)))
1646 (when message-citation-line-function 1801 (when message-citation-line-function
1647 (unless (bolp) 1802 (unless (bolp)
1648 (insert "\n")) 1803 (insert "\n"))
1649 (funcall message-citation-line-function))))) 1804 (funcall message-citation-line-function)))))
1650 1805
1651(defun message-insert-citation-line () 1806(defun message-insert-citation-line ()
1652 "Function that inserts a simple citation line." 1807 "Function that inserts a simple citation line."
@@ -1721,11 +1876,14 @@ The text will also be indented the normal way."
1721 (bury-buffer buf) 1876 (bury-buffer buf)
1722 (when (eq buf (current-buffer)) 1877 (when (eq buf (current-buffer))
1723 (message-bury buf))) 1878 (message-bury buf)))
1724 (message-do-actions actions)))) 1879 (message-do-actions actions)
1880 t)))
1725 1881
1726(defun message-dont-send () 1882(defun message-dont-send ()
1727 "Don't send the message you have been editing." 1883 "Don't send the message you have been editing."
1728 (interactive) 1884 (interactive)
1885 (set-buffer-modified-p t)
1886 (save-buffer)
1729 (let ((actions message-postpone-actions)) 1887 (let ((actions message-postpone-actions))
1730 (message-bury (current-buffer)) 1888 (message-bury (current-buffer))
1731 (message-do-actions actions))) 1889 (message-do-actions actions)))
@@ -1736,6 +1894,7 @@ The text will also be indented the normal way."
1736 (when (or (not (buffer-modified-p)) 1894 (when (or (not (buffer-modified-p))
1737 (yes-or-no-p "Message modified; kill anyway? ")) 1895 (yes-or-no-p "Message modified; kill anyway? "))
1738 (let ((actions message-kill-actions)) 1896 (let ((actions message-kill-actions))
1897 (setq buffer-file-name nil)
1739 (kill-buffer (current-buffer)) 1898 (kill-buffer (current-buffer))
1740 (message-do-actions actions)))) 1899 (message-do-actions actions))))
1741 1900
@@ -1756,13 +1915,10 @@ or error messages, and inform user.
1756Otherwise any failure is reported in a message back to 1915Otherwise any failure is reported in a message back to
1757the user from the mailer." 1916the user from the mailer."
1758 (interactive "P") 1917 (interactive "P")
1759 (when (if buffer-file-name 1918 ;; Disabled test.
1760 (y-or-n-p (format "Send buffer contents as %s message? " 1919 (when (or (buffer-modified-p)
1761 (if (message-mail-p) 1920 (message-check-element 'unchanged)
1762 (if (message-news-p) "mail and news" "mail") 1921 (y-or-n-p "No changes in the buffer; really send? "))
1763 "news")))
1764 (or (buffer-modified-p)
1765 (y-or-n-p "No changes in the buffer; really send? ")))
1766 ;; Make it possible to undo the coming changes. 1922 ;; Make it possible to undo the coming changes.
1767 (undo-boundary) 1923 (undo-boundary)
1768 (let ((inhibit-read-only t)) 1924 (let ((inhibit-read-only t))
@@ -1790,10 +1946,10 @@ the user from the mailer."
1790 ;; (mail-hist-put-headers-into-history)) 1946 ;; (mail-hist-put-headers-into-history))
1791 (run-hooks 'message-sent-hook) 1947 (run-hooks 'message-sent-hook)
1792 (message "Sending...done") 1948 (message "Sending...done")
1793 ;; If buffer has no file, mark it as unmodified and delete auto-save. 1949 ;; Mark the buffer as unmodified and delete auto-save.
1794 (unless buffer-file-name 1950 (set-buffer-modified-p nil)
1795 (set-buffer-modified-p nil) 1951 (delete-auto-save-file-if-necessary t)
1796 (delete-auto-save-file-if-necessary t)) 1952 (message-disassociate-draft)
1797 ;; Delete other mail buffers and stuff. 1953 ;; Delete other mail buffers and stuff.
1798 (message-do-send-housekeeping) 1954 (message-do-send-housekeeping)
1799 (message-do-actions message-send-actions) 1955 (message-do-actions message-send-actions)
@@ -1801,7 +1957,7 @@ the user from the mailer."
1801 t)))) 1957 t))))
1802 1958
1803(defun message-send-via-mail (arg) 1959(defun message-send-via-mail (arg)
1804 "Send the current message via mail." 1960 "Send the current message via mail."
1805 (message-send-mail arg)) 1961 (message-send-mail arg))
1806 1962
1807(defun message-send-via-news (arg) 1963(defun message-send-via-news (arg)
@@ -1813,7 +1969,13 @@ the user from the mailer."
1813 ;; Make sure there's a newline at the end of the message. 1969 ;; Make sure there's a newline at the end of the message.
1814 (goto-char (point-max)) 1970 (goto-char (point-max))
1815 (unless (bolp) 1971 (unless (bolp)
1816 (insert "\n"))) 1972 (insert "\n"))
1973 ;; Make all invisible text visible.
1974 ;;(when (text-property-any (point-min) (point-max) 'invisible t)
1975 ;; (put-text-property (point-min) (point-max) 'invisible nil)
1976 ;; (unless (yes-or-no-p "Invisible text found and made visible; continue posting?")
1977 ;; (error "Invisible text found and made visible")))
1978 )
1817 1979
1818(defun message-add-action (action &rest types) 1980(defun message-add-action (action &rest types)
1819 "Add ACTION to be performed when doing an exit of type TYPES." 1981 "Add ACTION to be performed when doing an exit of type TYPES."
@@ -1905,7 +2067,7 @@ the user from the mailer."
1905 (set-buffer errbuf) 2067 (set-buffer errbuf)
1906 (erase-buffer)))) 2068 (erase-buffer))))
1907 (let ((default-directory "/") 2069 (let ((default-directory "/")
1908 (coding-system-for-write (select-message-coding-system))) 2070 (coding-system-for-write message-send-coding-system))
1909 (apply 'call-process-region 2071 (apply 'call-process-region
1910 (append (list (point-min) (point-max) 2072 (append (list (point-min) (point-max)
1911 (if (boundp 'sendmail-program) 2073 (if (boundp 'sendmail-program)
@@ -1953,28 +2115,28 @@ to find out how to use this."
1953 (run-hooks 'message-send-mail-hook) 2115 (run-hooks 'message-send-mail-hook)
1954 ;; send the message 2116 ;; send the message
1955 (case 2117 (case
1956 (let ((coding-system-for-write (select-message-coding-system))) 2118 (let ((coding-system-for-write message-send-coding-system))
1957 (apply 2119 (apply
1958 'call-process-region 1 (point-max) message-qmail-inject-program 2120 'call-process-region 1 (point-max) message-qmail-inject-program
1959 nil nil nil 2121 nil nil nil
1960 ;; qmail-inject's default behaviour is to look for addresses on the 2122 ;; qmail-inject's default behaviour is to look for addresses on the
1961 ;; command line; if there're none, it scans the headers. 2123 ;; command line; if there're none, it scans the headers.
1962 ;; yes, it does The Right Thing w.r.t. Resent-To and it's kin. 2124 ;; yes, it does The Right Thing w.r.t. Resent-To and it's kin.
1963 ;; 2125 ;;
1964 ;; in general, ALL of qmail-inject's defaults are perfect for simply 2126 ;; in general, ALL of qmail-inject's defaults are perfect for simply
1965 ;; reading a formatted (i. e., at least a To: or Resent-To header) 2127 ;; reading a formatted (i. e., at least a To: or Resent-To header)
1966 ;; message from stdin. 2128 ;; message from stdin.
1967 ;; 2129 ;;
1968 ;; qmail also has the advantage of not having been raped by 2130 ;; qmail also has the advantage of not having been raped by
1969 ;; various vendors, so we don't have to allow for that, either -- 2131 ;; various vendors, so we don't have to allow for that, either --
1970 ;; compare this with message-send-mail-with-sendmail and weep 2132 ;; compare this with message-send-mail-with-sendmail and weep
1971 ;; for sendmail's lost innocence. 2133 ;; for sendmail's lost innocence.
1972 ;; 2134 ;;
1973 ;; all this is way cool coz it lets us keep the arguments entirely 2135 ;; all this is way cool coz it lets us keep the arguments entirely
1974 ;; free for -inject-arguments -- a big win for the user and for us 2136 ;; free for -inject-arguments -- a big win for the user and for us
1975 ;; since we don't have to play that double-guessing game and the user 2137 ;; since we don't have to play that double-guessing game and the user
1976 ;; gets full control (no gestapo'ish -f's, for instance). --sj 2138 ;; gets full control (no gestapo'ish -f's, for instance). --sj
1977 message-qmail-inject-args)) 2139 message-qmail-inject-args))
1978 ;; qmail-inject doesn't say anything on it's stdout/stderr, 2140 ;; qmail-inject doesn't say anything on it's stdout/stderr,
1979 ;; we have to look at the retval instead 2141 ;; we have to look at the retval instead
1980 (0 nil) 2142 (0 nil)
@@ -1986,10 +2148,7 @@ to find out how to use this."
1986(defun message-send-mail-with-mh () 2148(defun message-send-mail-with-mh ()
1987 "Send the prepared message buffer with mh." 2149 "Send the prepared message buffer with mh."
1988 (let ((mh-previous-window-config nil) 2150 (let ((mh-previous-window-config nil)
1989 (name (make-temp-name 2151 (name (mh-new-draft-name)))
1990 (concat (file-name-as-directory
1991 (expand-file-name message-auto-save-directory))
1992 "msg."))))
1993 (setq buffer-file-name name) 2152 (setq buffer-file-name name)
1994 ;; MH wants to generate these headers itself. 2153 ;; MH wants to generate these headers itself.
1995 (when message-mh-deletable-headers 2154 (when message-mh-deletable-headers
@@ -2055,12 +2214,14 @@ to find out how to use this."
2055 (replace-match "\n") 2214 (replace-match "\n")
2056 (backward-char 1)) 2215 (backward-char 1))
2057 (run-hooks 'message-send-news-hook) 2216 (run-hooks 'message-send-news-hook)
2058 (require (car method)) 2217 ;;(require (car method))
2059 (funcall (intern (format "%s-open-server" (car method))) 2218 ;;(funcall (intern (format "%s-open-server" (car method)))
2060 (cadr method) (cddr method)) 2219 ;;(cadr method) (cddr method))
2061 (setq result 2220 ;;(setq result
2062 (funcall (intern (format "%s-request-post" (car method))) 2221 ;; (funcall (intern (format "%s-request-post" (car method)))
2063 (cadr method)))) 2222 ;; (cadr method)))
2223 (gnus-open-server method)
2224 (setq result (gnus-request-post method)))
2064 (kill-buffer tembuf)) 2225 (kill-buffer tembuf))
2065 (set-buffer messbuf) 2226 (set-buffer messbuf)
2066 (if result 2227 (if result
@@ -2184,8 +2345,12 @@ to find out how to use this."
2184 (let* ((case-fold-search t) 2345 (let* ((case-fold-search t)
2185 (message-id (message-fetch-field "message-id" t))) 2346 (message-id (message-fetch-field "message-id" t)))
2186 (or (not message-id) 2347 (or (not message-id)
2348 ;; Is there an @ in the ID?
2187 (and (string-match "@" message-id) 2349 (and (string-match "@" message-id)
2188 (string-match "@[^\\.]*\\." message-id)) 2350 ;; Is there a dot in the ID?
2351 (string-match "@[^.]*\\." message-id)
2352 ;; Does the ID end with a dot?
2353 (not (string-match "\\.>" message-id)))
2189 (y-or-n-p 2354 (y-or-n-p
2190 (format "The Message-ID looks strange: \"%s\". Really post? " 2355 (format "The Message-ID looks strange: \"%s\". Really post? "
2191 message-id))))) 2356 message-id)))))
@@ -2325,8 +2490,7 @@ to find out how to use this."
2325 (message-check 'new-text 2490 (message-check 'new-text
2326 (or 2491 (or
2327 (not message-checksum) 2492 (not message-checksum)
2328 (not (and (eq (message-checksum) (car message-checksum)) 2493 (not (eq (message-checksum) message-checksum))
2329 (eq (buffer-size) (cdr message-checksum))))
2330 (y-or-n-p 2494 (y-or-n-p
2331 "It looks like no new text has been added. Really post? "))) 2495 "It looks like no new text has been added. Really post? ")))
2332 ;; Check the length of the signature. 2496 ;; Check the length of the signature.
@@ -2408,31 +2572,32 @@ to find out how to use this."
2408 ;; Remove empty lines in the header. 2572 ;; Remove empty lines in the header.
2409 (save-restriction 2573 (save-restriction
2410 (message-narrow-to-headers) 2574 (message-narrow-to-headers)
2575 ;; Remove blank lines.
2411 (while (re-search-forward "^[ \t]*\n" nil t) 2576 (while (re-search-forward "^[ \t]*\n" nil t)
2412 (replace-match "" t t))) 2577 (replace-match "" t t))
2413 2578
2414 ;; Correct Newsgroups and Followup-To headers: change sequence of 2579 ;; Correct Newsgroups and Followup-To headers: Change sequence of
2415 ;; spaces to comma and eliminate spaces around commas. Eliminate 2580 ;; spaces to comma and eliminate spaces around commas. Eliminate
2416 ;; embedded line breaks. 2581 ;; embedded line breaks.
2417 (goto-char (point-min)) 2582 (goto-char (point-min))
2418 (while (re-search-forward "^\\(Newsgroups\\|Followup-To\\): +" nil t) 2583 (while (re-search-forward "^\\(Newsgroups\\|Followup-To\\): +" nil t)
2419 (save-restriction 2584 (save-restriction
2420 (narrow-to-region 2585 (narrow-to-region
2421 (point) 2586 (point)
2422 (if (re-search-forward "^[^ \t]" nil t) 2587 (if (re-search-forward "^[^ \t]" nil t)
2423 (match-beginning 0) 2588 (match-beginning 0)
2424 (forward-line 1) 2589 (forward-line 1)
2425 (point))) 2590 (point)))
2426 (goto-char (point-min)) 2591 (goto-char (point-min))
2427 (while (re-search-forward "\n[ \t]+" nil t) 2592 (while (re-search-forward "\n[ \t]+" nil t)
2428 (replace-match " " t t)) ;No line breaks (too confusing) 2593 (replace-match " " t t)) ;No line breaks (too confusing)
2429 (goto-char (point-min)) 2594 (goto-char (point-min))
2430 (while (re-search-forward "[ \t\n]*,[ \t\n]*\\|[ \t]+" nil t) 2595 (while (re-search-forward "[ \t\n]*,[ \t\n]*\\|[ \t]+" nil t)
2431 (replace-match "," t t)) 2596 (replace-match "," t t))
2432 (goto-char (point-min)) 2597 (goto-char (point-min))
2433 ;; Remove trailing commas. 2598 ;; Remove trailing commas.
2434 (when (re-search-forward ",+$" nil t) 2599 (when (re-search-forward ",+$" nil t)
2435 (replace-match "" t t))))) 2600 (replace-match "" t t))))))
2436 2601
2437(defun message-make-date () 2602(defun message-make-date ()
2438 "Make a valid data header." 2603 "Make a valid data header."
@@ -2504,11 +2669,10 @@ to find out how to use this."
2504(defun message-make-organization () 2669(defun message-make-organization ()
2505 "Make an Organization header." 2670 "Make an Organization header."
2506 (let* ((organization 2671 (let* ((organization
2507 (or (getenv "ORGANIZATION") 2672 (when message-user-organization
2508 (when message-user-organization
2509 (if (message-functionp message-user-organization) 2673 (if (message-functionp message-user-organization)
2510 (funcall message-user-organization) 2674 (funcall message-user-organization)
2511 message-user-organization))))) 2675 message-user-organization))))
2512 (save-excursion 2676 (save-excursion
2513 (message-set-work-buffer) 2677 (message-set-work-buffer)
2514 (cond ((stringp organization) 2678 (cond ((stringp organization)
@@ -2542,7 +2706,9 @@ to find out how to use this."
2542 (when from 2706 (when from
2543 (let ((stop-pos 2707 (let ((stop-pos
2544 (string-match " *at \\| *@ \\| *(\\| *<" from))) 2708 (string-match " *at \\| *@ \\| *(\\| *<" from)))
2545 (concat (if stop-pos (substring from 0 stop-pos) from) 2709 (concat (if (and stop-pos
2710 (not (zerop stop-pos)))
2711 (substring from 0 stop-pos) from)
2546 "'s message of \"" 2712 "'s message of \""
2547 (if (or (not date) (string= date "")) 2713 (if (or (not date) (string= date ""))
2548 "(unknown date)" date) 2714 "(unknown date)" date)
@@ -2667,7 +2833,8 @@ give as trustworthy answer as possible."
2667 (string-match "\\." mail-host-address)) 2833 (string-match "\\." mail-host-address))
2668 mail-host-address) 2834 mail-host-address)
2669 ;; We try `user-mail-address' as a backup. 2835 ;; We try `user-mail-address' as a backup.
2670 ((and (string-match "\\." user-mail) 2836 ((and user-mail
2837 (string-match "\\." user-mail)
2671 (string-match "@\\(.*\\)\\'" user-mail)) 2838 (string-match "@\\(.*\\)\\'" user-mail))
2672 (match-string 1 user-mail)) 2839 (match-string 1 user-mail))
2673 ;; Default to this bogus thing. 2840 ;; Default to this bogus thing.
@@ -2731,7 +2898,13 @@ Headers already prepared in the buffer are not modified."
2731 (setq header (car elem))) 2898 (setq header (car elem)))
2732 (setq header elem)) 2899 (setq header elem))
2733 (when (or (not (re-search-forward 2900 (when (or (not (re-search-forward
2734 (concat "^" (downcase (symbol-name header)) ":") 2901 (concat "^"
2902 (regexp-quote
2903 (downcase
2904 (if (stringp header)
2905 header
2906 (symbol-name header))))
2907 ":")
2735 nil t)) 2908 nil t))
2736 (progn 2909 (progn
2737 ;; The header was found. We insert a space after the 2910 ;; The header was found. We insert a space after the
@@ -2773,7 +2946,8 @@ Headers already prepared in the buffer are not modified."
2773 (progn 2946 (progn
2774 ;; This header didn't exist, so we insert it. 2947 ;; This header didn't exist, so we insert it.
2775 (goto-char (point-max)) 2948 (goto-char (point-max))
2776 (insert (symbol-name header) ": " value "\n") 2949 (insert (if (stringp header) header (symbol-name header))
2950 ": " value "\n")
2777 (forward-line -1)) 2951 (forward-line -1))
2778 ;; The value of this header was empty, so we clear 2952 ;; The value of this header was empty, so we clear
2779 ;; totally and insert the new value. 2953 ;; totally and insert the new value.
@@ -2808,7 +2982,7 @@ Headers already prepared in the buffer are not modified."
2808 (insert "Original-") 2982 (insert "Original-")
2809 (beginning-of-line)) 2983 (beginning-of-line))
2810 (when (or (message-news-p) 2984 (when (or (message-news-p)
2811 (string-match "^[^@]@.+\\..+" secure-sender)) 2985 (string-match "@.+\\.." secure-sender))
2812 (insert "Sender: " secure-sender "\n"))))))) 2986 (insert "Sender: " secure-sender "\n")))))))
2813 2987
2814(defun message-insert-courtesy-copy () 2988(defun message-insert-courtesy-copy ()
@@ -2864,7 +3038,7 @@ Headers already prepared in the buffer are not modified."
2864 3038
2865(defun message-fill-header (header value) 3039(defun message-fill-header (header value)
2866 (let ((begin (point)) 3040 (let ((begin (point))
2867 (fill-column 78) 3041 (fill-column 990)
2868 (fill-prefix "\t")) 3042 (fill-prefix "\t"))
2869 (insert (capitalize (symbol-name header)) 3043 (insert (capitalize (symbol-name header))
2870 ": " 3044 ": "
@@ -2883,6 +3057,24 @@ Headers already prepared in the buffer are not modified."
2883 (replace-match " " t t)) 3057 (replace-match " " t t))
2884 (goto-char (point-max))))) 3058 (goto-char (point-max)))))
2885 3059
3060(defun message-shorten-references (header references)
3061 "Limit REFERENCES to be shorter than 988 characters."
3062 (let ((max 988)
3063 (cut 4)
3064 refs)
3065 (nnheader-temp-write nil
3066 (insert references)
3067 (goto-char (point-min))
3068 (while (re-search-forward "<[^>]+>" nil t)
3069 (push (match-string 0) refs))
3070 (setq refs (nreverse refs))
3071 (while (> (length (mapconcat 'identity refs " ")) max)
3072 (when (< (length refs) (1+ cut))
3073 (decf cut))
3074 (setcdr (nthcdr cut refs) (cddr (nthcdr cut refs)))))
3075 (insert (capitalize (symbol-name header)) ": "
3076 (mapconcat 'identity refs " ") "\n")))
3077
2886(defun message-position-point () 3078(defun message-position-point ()
2887 "Move point to where the user probably wants to find it." 3079 "Move point to where the user probably wants to find it."
2888 (message-narrow-to-headers) 3080 (message-narrow-to-headers)
@@ -2935,9 +3127,9 @@ Headers already prepared in the buffer are not modified."
2935 (not (y-or-n-p 3127 (not (y-or-n-p
2936 "Message already being composed; erase? "))) 3128 "Message already being composed; erase? ")))
2937 (error "Message being composed"))) 3129 (error "Message being composed")))
2938 (set-buffer (pop-to-buffer name)))) 3130 (set-buffer (pop-to-buffer name)))
2939 (erase-buffer) 3131 (erase-buffer)
2940 (message-mode)) 3132 (message-mode)))
2941 3133
2942(defun message-do-send-housekeeping () 3134(defun message-do-send-housekeeping ()
2943 "Kill old message buffers." 3135 "Kill old message buffers."
@@ -2986,7 +3178,8 @@ Headers already prepared in the buffer are not modified."
2986 headers) 3178 headers)
2987 (delete-region (point) (progn (forward-line -1) (point))) 3179 (delete-region (point) (progn (forward-line -1) (point)))
2988 (when message-default-headers 3180 (when message-default-headers
2989 (insert message-default-headers)) 3181 (insert message-default-headers)
3182 (or (bolp) (insert ?\n)))
2990 (put-text-property 3183 (put-text-property
2991 (point) 3184 (point)
2992 (progn 3185 (progn
@@ -2996,7 +3189,8 @@ Headers already prepared in the buffer are not modified."
2996 (forward-line -1) 3189 (forward-line -1)
2997 (when (message-news-p) 3190 (when (message-news-p)
2998 (when message-default-news-headers 3191 (when message-default-news-headers
2999 (insert message-default-news-headers)) 3192 (insert message-default-news-headers)
3193 (or (bolp) (insert ?\n)))
3000 (when message-generate-headers-first 3194 (when message-generate-headers-first
3001 (message-generate-headers 3195 (message-generate-headers
3002 (delq 'Lines 3196 (delq 'Lines
@@ -3004,7 +3198,8 @@ Headers already prepared in the buffer are not modified."
3004 (copy-sequence message-required-news-headers)))))) 3198 (copy-sequence message-required-news-headers))))))
3005 (when (message-mail-p) 3199 (when (message-mail-p)
3006 (when message-default-mail-headers 3200 (when message-default-mail-headers
3007 (insert message-default-mail-headers)) 3201 (insert message-default-mail-headers)
3202 (or (bolp) (insert ?\n)))
3008 (when message-generate-headers-first 3203 (when message-generate-headers-first
3009 (message-generate-headers 3204 (message-generate-headers
3010 (delq 'Lines 3205 (delq 'Lines
@@ -3012,7 +3207,6 @@ Headers already prepared in the buffer are not modified."
3012 (copy-sequence message-required-mail-headers)))))) 3207 (copy-sequence message-required-mail-headers))))))
3013 (run-hooks 'message-signature-setup-hook) 3208 (run-hooks 'message-signature-setup-hook)
3014 (message-insert-signature) 3209 (message-insert-signature)
3015 (message-set-auto-save-file-name)
3016 (save-restriction 3210 (save-restriction
3017 (message-narrow-to-headers) 3211 (message-narrow-to-headers)
3018 (run-hooks 'message-header-setup-hook)) 3212 (run-hooks 'message-header-setup-hook))
@@ -3025,25 +3219,19 @@ Headers already prepared in the buffer are not modified."
3025(defun message-set-auto-save-file-name () 3219(defun message-set-auto-save-file-name ()
3026 "Associate the message buffer with a file in the drafts directory." 3220 "Associate the message buffer with a file in the drafts directory."
3027 (when message-auto-save-directory 3221 (when message-auto-save-directory
3028 (unless (file-exists-p message-auto-save-directory) 3222 (if (gnus-alive-p)
3029 (make-directory message-auto-save-directory t)) 3223 (setq message-draft-article
3030 (let ((name (make-temp-name 3224 (nndraft-request-associate-buffer "drafts"))
3031 (expand-file-name 3225 (setq buffer-file-name (expand-file-name "*message*"
3032 (concat (file-name-as-directory message-auto-save-directory) 3226 message-auto-save-directory))
3033 "msg." 3227 (setq buffer-auto-save-file-name (make-auto-save-file-name)))
3034 (nnheader-replace-chars-in-string 3228 (clear-visited-file-modtime)))
3035 (nnheader-replace-chars-in-string 3229
3036 (buffer-name) ?* ?.) 3230(defun message-disassociate-draft ()
3037 ?/ ?-)))))) 3231 "Disassociate the message buffer from the drafts directory."
3038 (setq buffer-auto-save-file-name 3232 (when message-draft-article
3039 (save-excursion 3233 (nndraft-request-expire-articles
3040 (prog1 3234 (list message-draft-article) "drafts" nil t)))
3041 (progn
3042 (set-buffer (get-buffer-create " *draft tmp*"))
3043 (setq buffer-file-name name)
3044 (make-auto-save-file-name))
3045 (kill-buffer (current-buffer)))))
3046 (clear-visited-file-modtime))))
3047 3235
3048 3236
3049 3237
@@ -3055,7 +3243,8 @@ Headers already prepared in the buffer are not modified."
3055(defun message-mail (&optional to subject 3243(defun message-mail (&optional to subject
3056 other-headers continue switch-function 3244 other-headers continue switch-function
3057 yank-action send-actions) 3245 yank-action send-actions)
3058 "Start editing a mail message to be sent." 3246 "Start editing a mail message to be sent.
3247OTHER-HEADERS is an alist of header/value pairs."
3059 (interactive) 3248 (interactive)
3060 (let ((message-this-is-mail t)) 3249 (let ((message-this-is-mail t))
3061 (message-pop-to-buffer (message-buffer-name "mail" to)) 3250 (message-pop-to-buffer (message-buffer-name "mail" to))
@@ -3074,7 +3263,7 @@ Headers already prepared in the buffer are not modified."
3074 (Subject . ,(or subject "")))))) 3263 (Subject . ,(or subject ""))))))
3075 3264
3076;;;###autoload 3265;;;###autoload
3077(defun message-reply (&optional to-address wide ignore-reply-to) 3266(defun message-reply (&optional to-address wide)
3078 "Start editing a reply to the article in the current buffer." 3267 "Start editing a reply to the article in the current buffer."
3079 (interactive) 3268 (interactive)
3080 (let ((cur (current-buffer)) 3269 (let ((cur (current-buffer))
@@ -3101,12 +3290,12 @@ Headers already prepared in the buffer are not modified."
3101 to (message-fetch-field "to") 3290 to (message-fetch-field "to")
3102 cc (message-fetch-field "cc") 3291 cc (message-fetch-field "cc")
3103 mct (message-fetch-field "mail-copies-to") 3292 mct (message-fetch-field "mail-copies-to")
3104 reply-to (unless ignore-reply-to (message-fetch-field "reply-to")) 3293 reply-to (message-fetch-field "reply-to")
3105 references (message-fetch-field "references") 3294 references (message-fetch-field "references")
3106 message-id (message-fetch-field "message-id" t)) 3295 message-id (message-fetch-field "message-id" t))
3107 ;; Remove any (buggy) Re:'s that are present and make a 3296 ;; Remove any (buggy) Re:'s that are present and make a
3108 ;; proper one. 3297 ;; proper one.
3109 (when (string-match "^[ \t]*[Rr][Ee]:[ \t]*" subject) 3298 (when (string-match message-subject-re-regexp subject)
3110 (setq subject (substring subject (match-end 0)))) 3299 (setq subject (substring subject (match-end 0))))
3111 (setq subject (concat "Re: " subject)) 3300 (setq subject (concat "Re: " subject))
3112 3301
@@ -3125,7 +3314,10 @@ Headers already prepared in the buffer are not modified."
3125 (unless follow-to 3314 (unless follow-to
3126 (if (or (not wide) 3315 (if (or (not wide)
3127 to-address) 3316 to-address)
3128 (setq follow-to (list (cons 'To (or to-address reply-to from)))) 3317 (progn
3318 (setq follow-to (list (cons 'To (or to-address reply-to from))))
3319 (when (and wide mct)
3320 (push (cons 'Cc mct) follow-to)))
3129 (let (ccalist) 3321 (let (ccalist)
3130 (save-excursion 3322 (save-excursion
3131 (message-set-work-buffer) 3323 (message-set-work-buffer)
@@ -3178,10 +3370,10 @@ Headers already prepared in the buffer are not modified."
3178 cur))) 3370 cur)))
3179 3371
3180;;;###autoload 3372;;;###autoload
3181(defun message-wide-reply (&optional to-address ignore-reply-to) 3373(defun message-wide-reply (&optional to-address)
3182 "Make a \"wide\" reply to the message in the current buffer." 3374 "Make a \"wide\" reply to the message in the current buffer."
3183 (interactive) 3375 (interactive)
3184 (message-reply to-address t ignore-reply-to)) 3376 (message-reply to-address t))
3185 3377
3186;;;###autoload 3378;;;###autoload
3187(defun message-followup (&optional to-newsgroups) 3379(defun message-followup (&optional to-newsgroups)
@@ -3224,7 +3416,7 @@ If TO-NEWSGROUPS, use that as the new Newsgroups line."
3224 (setq distribution nil)) 3416 (setq distribution nil))
3225 ;; Remove any (buggy) Re:'s that are present and make a 3417 ;; Remove any (buggy) Re:'s that are present and make a
3226 ;; proper one. 3418 ;; proper one.
3227 (when (string-match "^[ \t]*[Rr][Ee]:[ \t]*" subject) 3419 (when (string-match message-subject-re-regexp subject)
3228 (setq subject (substring subject (match-end 0)))) 3420 (setq subject (substring subject (match-end 0))))
3229 (setq subject (concat "Re: " subject)) 3421 (setq subject (concat "Re: " subject))
3230 (widen)) 3422 (widen))
@@ -3301,19 +3493,25 @@ responses here are directed to other newsgroups."))
3301 (unless (message-news-p) 3493 (unless (message-news-p)
3302 (error "This is not a news article; canceling is impossible")) 3494 (error "This is not a news article; canceling is impossible"))
3303 (when (yes-or-no-p "Do you really want to cancel this article? ") 3495 (when (yes-or-no-p "Do you really want to cancel this article? ")
3304 (let (from newsgroups message-id distribution buf) 3496 (let (from newsgroups message-id distribution buf sender)
3305 (save-excursion 3497 (save-excursion
3306 ;; Get header info. from original article. 3498 ;; Get header info. from original article.
3307 (save-restriction 3499 (save-restriction
3308 (message-narrow-to-head) 3500 (message-narrow-to-head)
3309 (setq from (message-fetch-field "from") 3501 (setq from (message-fetch-field "from")
3502 sender (message-fetch-field "sender")
3310 newsgroups (message-fetch-field "newsgroups") 3503 newsgroups (message-fetch-field "newsgroups")
3311 message-id (message-fetch-field "message-id" t) 3504 message-id (message-fetch-field "message-id" t)
3312 distribution (message-fetch-field "distribution"))) 3505 distribution (message-fetch-field "distribution")))
3313 ;; Make sure that this article was written by the user. 3506 ;; Make sure that this article was written by the user.
3314 (unless (string-equal 3507 (unless (or (and sender
3315 (downcase (cadr (mail-extract-address-components from))) 3508 (string-equal
3316 (downcase (message-make-address))) 3509 (downcase sender)
3510 (downcase (message-make-sender))))
3511 (string-equal
3512 (downcase (cadr (mail-extract-address-components from)))
3513 (downcase (cadr (mail-extract-address-components
3514 (message-make-from))))))
3317 (error "This article is not yours")) 3515 (error "This article is not yours"))
3318 ;; Make control message. 3516 ;; Make control message.
3319 (setq buf (set-buffer (get-buffer-create " *message cancel*"))) 3517 (setq buf (set-buffer (get-buffer-create " *message cancel*")))
@@ -3341,12 +3539,18 @@ responses here are directed to other newsgroups."))
3341This is done simply by taking the old article and adding a Supersedes 3539This is done simply by taking the old article and adding a Supersedes
3342header line with the old Message-ID." 3540header line with the old Message-ID."
3343 (interactive) 3541 (interactive)
3344 (let ((cur (current-buffer))) 3542 (let ((cur (current-buffer))
3543 (sender (message-fetch-field "sender"))
3544 (from (message-fetch-field "from")))
3345 ;; Check whether the user owns the article that is to be superseded. 3545 ;; Check whether the user owns the article that is to be superseded.
3346 (unless (string-equal 3546 (unless (or (and sender
3347 (downcase (cadr (mail-extract-address-components 3547 (string-equal
3348 (message-fetch-field "from")))) 3548 (downcase sender)
3349 (downcase (message-make-address))) 3549 (downcase (message-make-sender))))
3550 (string-equal
3551 (downcase (cadr (mail-extract-address-components from)))
3552 (downcase (cadr (mail-extract-address-components
3553 (message-make-from))))))
3350 (error "This article is not yours")) 3554 (error "This article is not yours"))
3351 ;; Get a normal message buffer. 3555 ;; Get a normal message buffer.
3352 (message-pop-to-buffer (message-buffer-name "supersede")) 3556 (message-pop-to-buffer (message-buffer-name "supersede"))
@@ -3382,18 +3586,79 @@ header line with the old Message-ID."
3382 (insert-file-contents file-name nil))) 3586 (insert-file-contents file-name nil)))
3383 (t (error "message-recover cancelled"))))) 3587 (t (error "message-recover cancelled")))))
3384 3588
3589;;; Washing Subject:
3590
3591(defun message-wash-subject (subject)
3592 "Remove junk like \"Re:\", \"(fwd)\", etc. that was added to the subject by previous forwarders, replyers, etc."
3593 (nnheader-temp-write nil
3594 (insert-string subject)
3595 (goto-char (point-min))
3596 ;; strip Re/Fwd stuff off the beginning
3597 (while (re-search-forward
3598 "\\([Rr][Ee]:\\|[Ff][Ww][Dd]\\(\\[[0-9]*\\]\\)?:\\|[Ff][Ww]:\\)" nil t)
3599 (replace-match ""))
3600
3601 ;; and gnus-style forwards [foo@bar.com] subject
3602 (goto-char (point-min))
3603 (while (re-search-forward "\\[[^ \t]*\\(@\\|\\.\\)[^ \t]*\\]" nil t)
3604 (replace-match ""))
3605
3606 ;; and off the end
3607 (goto-char (point-max))
3608 (while (re-search-backward "([Ff][Ww][Dd])" nil t)
3609 (replace-match ""))
3610
3611 ;; and finally, any whitespace that was left-over
3612 (goto-char (point-min))
3613 (while (re-search-forward "^[ \t]+" nil t)
3614 (replace-match ""))
3615 (goto-char (point-max))
3616 (while (re-search-backward "[ \t]+$" nil t)
3617 (replace-match ""))
3618
3619 (buffer-string)))
3620
3385;;; Forwarding messages. 3621;;; Forwarding messages.
3386 3622
3623(defun message-forward-subject-author-subject (subject)
3624 "Generate a subject for a forwarded message.
3625The form is: [Source] Subject, where if the original message was mail,
3626Source is the sender, and if the original message was news, Source is
3627the list of newsgroups is was posted to."
3628 (concat "["
3629 (or (message-fetch-field
3630 (if (message-news-p) "newsgroups" "from"))
3631 "(nowhere)")
3632 "] " subject))
3633
3634(defun message-forward-subject-fwd (subject)
3635 "Generate a subject for a forwarded message.
3636The form is: Fwd: Subject, where Subject is the original subject of
3637the message."
3638 (concat "Fwd: " subject))
3639
3387(defun message-make-forward-subject () 3640(defun message-make-forward-subject ()
3388 "Return a Subject header suitable for the message in the current buffer." 3641 "Return a Subject header suitable for the message in the current buffer."
3389 (save-excursion 3642 (save-excursion
3390 (save-restriction 3643 (save-restriction
3391 (current-buffer) 3644 (current-buffer)
3392 (message-narrow-to-head) 3645 (message-narrow-to-head)
3393 (concat "[" (or (message-fetch-field 3646 (let ((funcs message-make-forward-subject-function)
3394 (if (message-news-p) "newsgroups" "from")) 3647 (subject (if message-wash-forwarded-subjects
3395 "(nowhere)") 3648 (message-wash-subject
3396 "] " (or (message-fetch-field "Subject") ""))))) 3649 (or (message-fetch-field "Subject") ""))
3650 (or (message-fetch-field "Subject") ""))))
3651 ;; Make sure funcs is a list.
3652 (and funcs
3653 (not (listp funcs))
3654 (setq funcs (list funcs)))
3655 ;; Apply funcs in order, passing subject generated by previous
3656 ;; func to the next one.
3657 (while funcs
3658 (when (message-functionp (car funcs))
3659 (setq subject (funcall (car funcs) subject)))
3660 (setq funcs (cdr funcs)))
3661 subject))))
3397 3662
3398;;;###autoload 3663;;;###autoload
3399(defun message-forward (&optional news) 3664(defun message-forward (&optional news)
@@ -3466,7 +3731,7 @@ Optional NEWS will use news to forward instead of mail."
3466 (goto-char (point-max))) 3731 (goto-char (point-max)))
3467 (insert mail-header-separator) 3732 (insert mail-header-separator)
3468 ;; Rename all old ("Also-")Resent headers. 3733 ;; Rename all old ("Also-")Resent headers.
3469 (while (re-search-backward "^\\(Also-\\)?Resent-" beg t) 3734 (while (re-search-backward "^\\(Also-\\)*Resent-" beg t)
3470 (beginning-of-line) 3735 (beginning-of-line)
3471 (insert "Also-")) 3736 (insert "Also-"))
3472 ;; Quote any "From " lines at the beginning. 3737 ;; Quote any "From " lines at the beginning.
@@ -3533,7 +3798,8 @@ you."
3533 (same-window-buffer-names nil) 3798 (same-window-buffer-names nil)
3534 (same-window-regexps nil)) 3799 (same-window-regexps nil))
3535 (message-pop-to-buffer (message-buffer-name "mail" to))) 3800 (message-pop-to-buffer (message-buffer-name "mail" to)))
3536 (message-setup `((To . ,(or to "")) (Subject . ,(or subject ""))))) 3801 (let ((message-this-is-mail t))
3802 (message-setup `((To . ,(or to "")) (Subject . ,(or subject ""))))))
3537 3803
3538;;;###autoload 3804;;;###autoload
3539(defun message-mail-other-frame (&optional to subject) 3805(defun message-mail-other-frame (&optional to subject)
@@ -3545,7 +3811,8 @@ you."
3545 (same-window-buffer-names nil) 3811 (same-window-buffer-names nil)
3546 (same-window-regexps nil)) 3812 (same-window-regexps nil))
3547 (message-pop-to-buffer (message-buffer-name "mail" to))) 3813 (message-pop-to-buffer (message-buffer-name "mail" to)))
3548 (message-setup `((To . ,(or to "")) (Subject . ,(or subject ""))))) 3814 (let ((message-this-is-mail t))
3815 (message-setup `((To . ,(or to "")) (Subject . ,(or subject ""))))))
3549 3816
3550;;;###autoload 3817;;;###autoload
3551(defun message-news-other-window (&optional newsgroups subject) 3818(defun message-news-other-window (&optional newsgroups subject)
@@ -3557,8 +3824,9 @@ you."
3557 (same-window-buffer-names nil) 3824 (same-window-buffer-names nil)
3558 (same-window-regexps nil)) 3825 (same-window-regexps nil))
3559 (message-pop-to-buffer (message-buffer-name "news" nil newsgroups))) 3826 (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)))
3560 (message-setup `((Newsgroups . ,(or newsgroups "")) 3827 (let ((message-this-is-news t))
3561 (Subject . ,(or subject ""))))) 3828 (message-setup `((Newsgroups . ,(or newsgroups ""))
3829 (Subject . ,(or subject ""))))))
3562 3830
3563;;;###autoload 3831;;;###autoload
3564(defun message-news-other-frame (&optional newsgroups subject) 3832(defun message-news-other-frame (&optional newsgroups subject)
@@ -3570,8 +3838,9 @@ you."
3570 (same-window-buffer-names nil) 3838 (same-window-buffer-names nil)
3571 (same-window-regexps nil)) 3839 (same-window-regexps nil))
3572 (message-pop-to-buffer (message-buffer-name "news" nil newsgroups))) 3840 (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)))
3573 (message-setup `((Newsgroups . ,(or newsgroups "")) 3841 (let ((message-this-is-news t))
3574 (Subject . ,(or subject ""))))) 3842 (message-setup `((Newsgroups . ,(or newsgroups ""))
3843 (Subject . ,(or subject ""))))))
3575 3844
3576;;; underline.el 3845;;; underline.el
3577 3846
@@ -3630,6 +3899,7 @@ Do a `tab-to-tab-stop' if not in those headers."
3630 3899
3631(defvar gnus-active-hashtb) 3900(defvar gnus-active-hashtb)
3632(defun message-expand-group () 3901(defun message-expand-group ()
3902 "Expand the group name under point."
3633 (let* ((b (save-excursion 3903 (let* ((b (save-excursion
3634 (save-restriction 3904 (save-restriction
3635 (narrow-to-region 3905 (narrow-to-region
@@ -3640,10 +3910,10 @@ Do a `tab-to-tab-stop' if not in those headers."
3640 (point)) 3910 (point))
3641 (skip-chars-backward "^, \t\n") (point)))) 3911 (skip-chars-backward "^, \t\n") (point))))
3642 (completion-ignore-case t) 3912 (completion-ignore-case t)
3643 (string (buffer-substring b (point))) 3913 (string (buffer-substring b (progn (skip-chars-forward "^,\t\n ")
3914 (point))))
3644 (hashtb (and (boundp 'gnus-active-hashtb) gnus-active-hashtb)) 3915 (hashtb (and (boundp 'gnus-active-hashtb) gnus-active-hashtb))
3645 (completions (all-completions string hashtb)) 3916 (completions (all-completions string hashtb))
3646 (cur (current-buffer))
3647 comp) 3917 comp)
3648 (delete-region b (point)) 3918 (delete-region b (point))
3649 (cond 3919 (cond
@@ -3716,13 +3986,29 @@ regexp varstr."
3716 (regexp "^gnus\\|^nn\\|^message")) 3986 (regexp "^gnus\\|^nn\\|^message"))
3717 (mapcar 3987 (mapcar
3718 (lambda (local) 3988 (lambda (local)
3719 (when (and (car local) 3989 (when (and (consp local)
3990 (car local)
3720 (string-match regexp (symbol-name (car local)))) 3991 (string-match regexp (symbol-name (car local))))
3721 (ignore-errors 3992 (ignore-errors
3722 (set (make-local-variable (car local)) 3993 (set (make-local-variable (car local))
3723 (cdr local))))) 3994 (cdr local)))))
3724 locals))) 3995 locals)))
3725 3996
3997;;; Miscellaneous functions
3998
3999;; stolen (and renamed) from nnheader.el
4000(defun message-replace-chars-in-string (string from to)
4001 "Replace characters in STRING from FROM to TO."
4002 (let ((string (substring string 0)) ;Copy string.
4003 (len (length string))
4004 (idx 0))
4005 ;; Replace all occurrences of FROM with TO.
4006 (while (< idx len)
4007 (when (= (aref string idx) from)
4008 (aset string idx to))
4009 (setq idx (1+ idx)))
4010 string))
4011
3726(run-hooks 'message-load-hook) 4012(run-hooks 'message-load-hook)
3727 4013
3728(provide 'message) 4014(provide 'message)
diff --git a/lisp/gnus/messcompat.el b/lisp/gnus/messcompat.el
index 19371fe9354..870992476e7 100644
--- a/lisp/gnus/messcompat.el
+++ b/lisp/gnus/messcompat.el
@@ -1,7 +1,7 @@
1;;; messcompat.el --- making message mode compatible with mail mode 1;;; messcompat.el --- making message mode compatible with mail mode
2;; Copyright (C) 1996,97 Free Software Foundation, Inc. 2;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: mail, news 5;; Keywords: mail, news
6 6
7;; This file is part of GNU Emacs. 7;; This file is part of GNU Emacs.
@@ -56,8 +56,9 @@ nil means let mailer mail back a message to report errors.")
56 "Normal hook, run each time a new outgoing message is initialized. 56 "Normal hook, run each time a new outgoing message is initialized.
57The function `message-setup' runs this hook.") 57The function `message-setup' runs this hook.")
58 58
59(defvar message-mode-hook mail-mode-hook 59(if (boundp 'mail-mode-hook)
60 "Hook run in message mode buffers.") 60 (defvar message-mode-hook mail-mode-hook
61 "Hook run in message mode buffers."))
61 62
62(defvar message-indentation-spaces mail-indentation-spaces 63(defvar message-indentation-spaces mail-indentation-spaces
63 "*Number of spaces to insert at the beginning of each cited line. 64 "*Number of spaces to insert at the beginning of each cited line.
@@ -69,9 +70,8 @@ If t, the `message-signature-file' file will be inserted instead.
69If a function, the result from the function will be used instead. 70If a function, the result from the function will be used instead.
70If a form, the result from the form will be used instead.") 71If a form, the result from the form will be used instead.")
71 72
72;; Deleted the autoload cookie because this crashes in loaddefs.el.
73(defvar message-signature-file mail-signature-file 73(defvar message-signature-file mail-signature-file
74 "*File containing the text inserted at end of message. buffer.") 74 "*File containing the text inserted at end of the message buffer.")
75 75
76(defvar message-default-headers mail-default-headers 76(defvar message-default-headers mail-default-headers
77 "*A string containing header lines to be inserted in outgoing messages. 77 "*A string containing header lines to be inserted in outgoing messages.
@@ -81,6 +81,11 @@ these lines.")
81(defvar message-send-hook mail-send-hook 81(defvar message-send-hook mail-send-hook
82 "Hook run before sending messages.") 82 "Hook run before sending messages.")
83 83
84(defvar message-send-mail-function send-mail-function
85 "Function to call to send the current buffer as mail.
86The headers should be delimited by a line whose contents match the
87variable `mail-header-separator'.")
88
84(provide 'messcompat) 89(provide 'messcompat)
85 90
86;;; messcompat.el ends here 91;;; messcompat.el ends here
diff --git a/lisp/gnus/nnbabyl.el b/lisp/gnus/nnbabyl.el
index 8c37024e9ae..def1e0c9403 100644
--- a/lisp/gnus/nnbabyl.el
+++ b/lisp/gnus/nnbabyl.el
@@ -1,7 +1,7 @@
1;;; nnbabyl.el --- rmail mbox access for Gnus 1;;; nnbabyl.el --- rmail mbox access for Gnus
2;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. 2;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> 5;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
6;; Keywords: news, mail 6;; Keywords: news, mail
7 7
@@ -30,7 +30,9 @@
30;;; Code: 30;;; Code:
31 31
32(require 'nnheader) 32(require 'nnheader)
33(require 'rmail) 33(condition-case nil
34 (require 'rmail)
35 (t (nnheader-message 5 "Ignore rmail errors from this file, you don't have rmail")))
34(require 'nnmail) 36(require 'nnmail)
35(require 'nnoo) 37(require 'nnoo)
36(eval-when-compile (require 'cl)) 38(eval-when-compile (require 'cl))
@@ -240,7 +242,7 @@
240 (nnmail-activate 'nnbabyl) 242 (nnmail-activate 'nnbabyl)
241 (unless (assoc group nnbabyl-group-alist) 243 (unless (assoc group nnbabyl-group-alist)
242 (push (list group (cons 1 0)) 244 (push (list group (cons 1 0))
243 nnbabyl-group-alist) 245 nnbabyl-group-alist)
244 (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)) 246 (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file))
245 t) 247 t)
246 248
@@ -643,7 +645,7 @@
643 (when (buffer-modified-p (current-buffer)) 645 (when (buffer-modified-p (current-buffer))
644 (save-buffer)) 646 (save-buffer))
645 (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file) 647 (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
646 (message "")))) 648 (nnheader-message 5 ""))))
647 649
648(provide 'nnbabyl) 650(provide 'nnbabyl)
649 651
diff --git a/lisp/gnus/nndir.el b/lisp/gnus/nndir.el
index 89d4954c26b..a3b5eaef20d 100644
--- a/lisp/gnus/nndir.el
+++ b/lisp/gnus/nndir.el
@@ -1,7 +1,7 @@
1;;; nndir.el --- single directory newsgroup access for Gnus 1;;; nndir.el --- single directory newsgroup access for Gnus
2;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. 2;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: news 5;; Keywords: news
6 6
7;; This file is part of GNU Emacs. 7;; This file is part of GNU Emacs.
@@ -88,11 +88,11 @@
88 88
89(nnoo-map-functions nndir 89(nnoo-map-functions nndir
90 (nnml-retrieve-headers 0 nndir-current-group 0 0) 90 (nnml-retrieve-headers 0 nndir-current-group 0 0)
91 (nnmh-request-article 0 nndir-current-group 0 0) 91 (nnml-request-article 0 nndir-current-group 0 0)
92 (nnmh-request-group nndir-current-group 0 0) 92 (nnmh-request-group nndir-current-group 0 0)
93 (nnml-close-group nndir-current-group 0) 93 (nnml-close-group nndir-current-group 0)
94 (nnmh-request-list (nnoo-current-server 'nndir) nndir-directory) 94 (nnml-request-list (nnoo-current-server 'nndir) nndir-directory)
95 (nnmh-request-newsgroups (nnoo-current-server 'nndir) nndir-directory)) 95 (nnml-request-newsgroups (nnoo-current-server 'nndir) nndir-directory))
96 96
97(provide 'nndir) 97(provide 'nndir)
98 98
diff --git a/lisp/gnus/nndoc.el b/lisp/gnus/nndoc.el
index e0816e8dce8..0da245a7cab 100644
--- a/lisp/gnus/nndoc.el
+++ b/lisp/gnus/nndoc.el
@@ -1,7 +1,7 @@
1;;; nndoc.el --- single file access for Gnus 1;;; nndoc.el --- single file access for Gnus
2;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. 2;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> 5;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
6;; Keywords: news 6;; Keywords: news
7 7
@@ -30,6 +30,7 @@
30(require 'message) 30(require 'message)
31(require 'nnmail) 31(require 'nnmail)
32(require 'nnoo) 32(require 'nnoo)
33(require 'gnus-util)
33(eval-when-compile (require 'cl)) 34(eval-when-compile (require 'cl))
34 35
35(nnoo-declare nndoc) 36(nnoo-declare nndoc)
@@ -37,12 +38,17 @@
37(defvoo nndoc-article-type 'guess 38(defvoo nndoc-article-type 'guess
38 "*Type of the file. 39 "*Type of the file.
39One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward', 40One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward',
40`rfc934', `rfc822-forward', `mime-digest', `standard-digest', 41`rfc934', `rfc822-forward', `mime-digest', `mime-parts', `standard-digest',
41`slack-digest', `clari-briefs' or `guess'.") 42`slack-digest', `clari-briefs' or `guess'.")
42 43
43(defvoo nndoc-post-type 'mail 44(defvoo nndoc-post-type 'mail
44 "*Whether the nndoc group is `mail' or `post'.") 45 "*Whether the nndoc group is `mail' or `post'.")
45 46
47(defvoo nndoc-open-document-hook 'nnheader-ms-strip-cr
48 "Hook run after opening a document.
49The default function removes all trailing carriage returns
50from the document.")
51
46(defvar nndoc-type-alist 52(defvar nndoc-type-alist
47 `((mmdf 53 `((mmdf
48 (article-begin . "^\^A\^A\^A\^A\n") 54 (article-begin . "^\^A\^A\^A\^A\n")
@@ -81,13 +87,16 @@ One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward',
81 (body-end . "") 87 (body-end . "")
82 (file-end . "") 88 (file-end . "")
83 (subtype digest guess)) 89 (subtype digest guess))
90 (mime-parts
91 (generate-head-function . nndoc-generate-mime-parts-head)
92 (article-transform-function . nndoc-transform-mime-parts))
84 (standard-digest 93 (standard-digest
85 (first-article . ,(concat "^" (make-string 70 ?-) "\n\n+")) 94 (first-article . ,(concat "^" (make-string 70 ?-) "\n *\n+"))
86 (article-begin . ,(concat "^\n" (make-string 30 ?-) "\n\n+")) 95 (article-begin . ,(concat "^\n" (make-string 30 ?-) "\n *\n+"))
87 (prepare-body-function . nndoc-unquote-dashes) 96 (prepare-body-function . nndoc-unquote-dashes)
88 (body-end-function . nndoc-digest-body-end) 97 (body-end-function . nndoc-digest-body-end)
89 (head-end . "^ ?$") 98 (head-end . "^ *$")
90 (body-begin . "^ ?\n") 99 (body-begin . "^ *\n")
91 (file-end . "^End of .*digest.*[0-9].*\n\\*\\*\\|^End of.*Digest *$") 100 (file-end . "^End of .*digest.*[0-9].*\n\\*\\*\\|^End of.*Digest *$")
92 (subtype digest guess)) 101 (subtype digest guess))
93 (slack-digest 102 (slack-digest
@@ -122,10 +131,8 @@ One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward',
122 (subtype nil)))) 131 (subtype nil))))
123 132
124 133
125
126(defvoo nndoc-file-begin nil) 134(defvoo nndoc-file-begin nil)
127(defvoo nndoc-first-article nil) 135(defvoo nndoc-first-article nil)
128(defvoo nndoc-article-end nil)
129(defvoo nndoc-article-begin nil) 136(defvoo nndoc-article-begin nil)
130(defvoo nndoc-head-begin nil) 137(defvoo nndoc-head-begin nil)
131(defvoo nndoc-head-end nil) 138(defvoo nndoc-head-end nil)
@@ -135,6 +142,11 @@ One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward',
135(defvoo nndoc-body-begin-function nil) 142(defvoo nndoc-body-begin-function nil)
136(defvoo nndoc-head-begin-function nil) 143(defvoo nndoc-head-begin-function nil)
137(defvoo nndoc-body-end nil) 144(defvoo nndoc-body-end nil)
145;; nndoc-dissection-alist is a list of sublists. Each sublist holds the
146;; following items. ARTICLE is an ordinal starting at 1. HEAD-BEGIN,
147;; HEAD-END, BODY-BEGIN and BODY-END are positions in the `nndoc' buffer.
148;; LINE-COUNT is a count of lines in the body. SUBJECT, MESSAGE-ID and
149;; REFERENCES, only present for MIME dissections, are field values.
138(defvoo nndoc-dissection-alist nil) 150(defvoo nndoc-dissection-alist nil)
139(defvoo nndoc-prepare-body-function nil) 151(defvoo nndoc-prepare-body-function nil)
140(defvoo nndoc-generate-head-function nil) 152(defvoo nndoc-generate-head-function nil)
@@ -146,6 +158,8 @@ One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward',
146(defvoo nndoc-current-buffer nil 158(defvoo nndoc-current-buffer nil
147 "Current nndoc news buffer.") 159 "Current nndoc news buffer.")
148(defvoo nndoc-address nil) 160(defvoo nndoc-address nil)
161(defvoo nndoc-mime-header nil)
162(defvoo nndoc-mime-subject nil)
149 163
150(defconst nndoc-version "nndoc 1.0" 164(defconst nndoc-version "nndoc 1.0"
151 "nndoc version.") 165 "nndoc version.")
@@ -279,14 +293,17 @@ One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward',
279 (erase-buffer) 293 (erase-buffer)
280 (if (stringp nndoc-address) 294 (if (stringp nndoc-address)
281 (nnheader-insert-file-contents nndoc-address) 295 (nnheader-insert-file-contents nndoc-address)
282 (insert-buffer-substring nndoc-address))))) 296 (insert-buffer-substring nndoc-address))
297 (run-hooks 'nndoc-open-document-hook))))
283 ;; Initialize the nndoc structures according to this new document. 298 ;; Initialize the nndoc structures according to this new document.
284 (when (and nndoc-current-buffer 299 (when (and nndoc-current-buffer
285 (not nndoc-dissection-alist)) 300 (not nndoc-dissection-alist))
286 (save-excursion 301 (save-excursion
287 (set-buffer nndoc-current-buffer) 302 (set-buffer nndoc-current-buffer)
288 (nndoc-set-delims) 303 (nndoc-set-delims)
289 (nndoc-dissect-buffer))) 304 (if (eq nndoc-article-type 'mime-parts)
305 (nndoc-dissect-mime-parts)
306 (nndoc-dissect-buffer))))
290 (unless nndoc-current-buffer 307 (unless nndoc-current-buffer
291 (nndoc-close-server)) 308 (nndoc-close-server))
292 ;; Return whether we managed to select a file. 309 ;; Return whether we managed to select a file.
@@ -300,7 +317,8 @@ One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward',
300 "Set the nndoc delimiter variables according to the type of the document." 317 "Set the nndoc delimiter variables according to the type of the document."
301 (let ((vars '(nndoc-file-begin 318 (let ((vars '(nndoc-file-begin
302 nndoc-first-article 319 nndoc-first-article
303 nndoc-article-end nndoc-head-begin nndoc-head-end 320 nndoc-article-begin-function
321 nndoc-head-begin nndoc-head-end
304 nndoc-file-end nndoc-article-begin 322 nndoc-file-end nndoc-article-begin
305 nndoc-body-begin nndoc-body-end-function nndoc-body-end 323 nndoc-body-begin nndoc-body-end-function nndoc-body-end
306 nndoc-prepare-body-function nndoc-article-transform-function 324 nndoc-prepare-body-function nndoc-article-transform-function
@@ -334,7 +352,7 @@ One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward',
334 (error "Document is not of any recognized type")) 352 (error "Document is not of any recognized type"))
335 (if result 353 (if result
336 (car entry) 354 (car entry)
337 (cadar (sort results (lambda (r1 r2) (< (car r1) (car r2)))))))) 355 (cadar (sort results 'car-less-than-car)))))
338 356
339;;; 357;;;
340;;; Built-in type predicates and functions 358;;; Built-in type predicates and functions
@@ -390,7 +408,7 @@ One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward',
390 408
391(defun nndoc-babyl-body-begin () 409(defun nndoc-babyl-body-begin ()
392 (re-search-forward "^\n" nil t) 410 (re-search-forward "^\n" nil t)
393 (when (looking-at "\*\*\* EOOH \*\*\*") 411 (when (looking-at "\\*\\*\\* EOOH \\*\\*\\*")
394 (let ((next (or (save-excursion 412 (let ((next (or (save-excursion
395 (re-search-forward nndoc-article-begin nil t)) 413 (re-search-forward nndoc-article-begin nil t))
396 (point-max)))) 414 (point-max))))
@@ -402,7 +420,7 @@ One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward',
402 420
403(defun nndoc-babyl-head-begin () 421(defun nndoc-babyl-head-begin ()
404 (when (re-search-forward "^[0-9].*\n" nil t) 422 (when (re-search-forward "^[0-9].*\n" nil t)
405 (when (looking-at "\*\*\* EOOH \*\*\*") 423 (when (looking-at "\\*\\*\\* EOOH \\*\\*\\*")
406 (forward-line 1)) 424 (forward-line 1))
407 t)) 425 t))
408 426
@@ -429,6 +447,44 @@ One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward',
429(defun nndoc-rfc822-forward-body-end-function () 447(defun nndoc-rfc822-forward-body-end-function ()
430 (goto-char (point-max))) 448 (goto-char (point-max)))
431 449
450(defun nndoc-mime-parts-type-p ()
451 (let ((case-fold-search t)
452 (limit (search-forward "\n\n" nil t)))
453 (goto-char (point-min))
454 (when (and limit
455 (re-search-forward
456 (concat "\
457^Content-Type:[ \t]*multipart/[a-z]+;\\(.*;\\)*"
458 "[ \t\n]*[ \t]boundary=\"?[^\"\n]*[^\" \t\n]")
459 limit t))
460 t)))
461
462(defun nndoc-transform-mime-parts (article)
463 (unless (= article 1)
464 ;; Ensure some MIME-Version.
465 (goto-char (point-min))
466 (search-forward "\n\n")
467 (let ((case-fold-search nil)
468 (limit (point)))
469 (goto-char (point-min))
470 (or (save-excursion (re-search-forward "^MIME-Version:" limit t))
471 (insert "Mime-Version: 1.0\n")))
472 ;; Generate default header before entity fields.
473 (goto-char (point-min))
474 (nndoc-generate-mime-parts-head article t)))
475
476(defun nndoc-generate-mime-parts-head (article &optional body-present)
477 (let ((entry (cdr (assq (if body-present 1 article) nndoc-dissection-alist))))
478 (let ((subject (if body-present
479 nndoc-mime-subject
480 (concat "<" (nth 5 entry) ">")))
481 (message-id (nth 6 entry))
482 (references (nth 7 entry)))
483 (insert nndoc-mime-header)
484 (and subject (insert "Subject: " subject "\n"))
485 (and message-id (insert "Message-ID: " message-id "\n"))
486 (and references (insert "References: " references "\n")))))
487
432(defun nndoc-clari-briefs-type-p () 488(defun nndoc-clari-briefs-type-p ()
433 (when (let ((case-fold-search nil)) 489 (when (let ((case-fold-search nil))
434 (re-search-forward "^\t[^a-z]+ ([^a-z]+) --" nil t)) 490 (re-search-forward "^\t[^a-z]+ ([^a-z]+) --" nil t))
@@ -466,7 +522,7 @@ One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward',
466 (when (and 522 (when (and
467 (re-search-forward 523 (re-search-forward
468 (concat "^Content-Type: *multipart/digest;[ \t\n]*[ \t]" 524 (concat "^Content-Type: *multipart/digest;[ \t\n]*[ \t]"
469 "boundary=\"\\([^\"\n]*[^\" \t\n]\\)\"") 525 "boundary=\"?\\([^\"\n]*[^\" \t\n]\\)")
470 nil t) 526 nil t)
471 (match-beginning 1)) 527 (match-beginning 1))
472 (setq boundary-id (match-string 1) 528 (setq boundary-id (match-string 1)
@@ -530,6 +586,9 @@ One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward',
530 (insert "From: " (or from "unknown") 586 (insert "From: " (or from "unknown")
531 "\nSubject: " (or subject "(no subject)") "\n"))) 587 "\nSubject: " (or subject "(no subject)") "\n")))
532 588
589(deffoo nndoc-request-accept-article (group &optional server last)
590 nil)
591
533 592
534 593
535;;; 594;;;
@@ -562,7 +621,7 @@ One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward',
562 (funcall nndoc-head-begin-function)) 621 (funcall nndoc-head-begin-function))
563 (nndoc-head-begin 622 (nndoc-head-begin
564 (nndoc-search nndoc-head-begin))) 623 (nndoc-search nndoc-head-begin)))
565 (if (or (>= (point) (point-max)) 624 (if (or (eobp)
566 (and nndoc-file-end 625 (and nndoc-file-end
567 (looking-at nndoc-file-end))) 626 (looking-at nndoc-file-end)))
568 (goto-char (point-max)) 627 (goto-char (point-max))
@@ -599,6 +658,104 @@ One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward',
599 (while (re-search-forward "^- -"nil t) 658 (while (re-search-forward "^- -"nil t)
600 (replace-match "-" t t))) 659 (replace-match "-" t t)))
601 660
661;; Against compiler warnings.
662(defvar nndoc-mime-split-ordinal)
663
664(defun nndoc-dissect-mime-parts ()
665 "Go through a MIME composite article and partition it into sub-articles.
666When a MIME entity contains sub-entities, dissection produces one article for
667the header of this entity, and one article per sub-entity."
668 (setq nndoc-dissection-alist nil
669 nndoc-mime-split-ordinal 0)
670 (save-excursion
671 (set-buffer nndoc-current-buffer)
672 (message-narrow-to-head)
673 (let ((case-fold-search t)
674 (message-id (message-fetch-field "Message-ID"))
675 (references (message-fetch-field "References")))
676 (setq nndoc-mime-header (buffer-substring (point-min) (point-max))
677 nndoc-mime-subject (message-fetch-field "Subject"))
678 (while (string-match "\
679^\\(Subject\\|Message-ID\\|References\\|Lines\\|\
680MIME-Version\\|Content-Type\\|Content-Transfer-Encoding\\|\
681\\):.*\n\\([ \t].*\n\\)*"
682 nndoc-mime-header)
683 (setq nndoc-mime-header (replace-match "" t t nndoc-mime-header)))
684 (widen)
685 (nndoc-dissect-mime-parts-sub (point-min) (point-max)
686 nil message-id references))))
687
688(defun nndoc-dissect-mime-parts-sub (begin end position message-id references)
689 "Dissect an entity within a composite MIME message.
690The article, which corresponds to a MIME entity, extends from BEGIN to END.
691The string POSITION holds a dotted decimal representation of the article
692position in the hierarchical structure, it is nil for the outer entity.
693The generated article should use MESSAGE-ID and REFERENCES field values."
694 ;; Note: `case-fold-search' is already `t' from the calling function.
695 (let ((head-begin begin)
696 (body-end end)
697 head-end body-begin type subtype composite comment)
698 (save-excursion
699 ;; Gracefully handle a missing body.
700 (goto-char head-begin)
701 (if (search-forward "\n\n" body-end t)
702 (setq head-end (1- (point))
703 body-begin (point))
704 (setq head-end end
705 body-begin end))
706 ;; Save MIME attributes.
707 (goto-char head-begin)
708 (if (re-search-forward "\
709^Content-Type: *\\([^ \t\n/;]+\\)/\\([^ \t\n/;]+\\)"
710 head-end t)
711 (setq type (downcase (match-string 1))
712 subtype (downcase (match-string 2)))
713 (setq type "text"
714 subtype "plain"))
715 (setq composite (string= type "multipart")
716 comment (concat position
717 (when (and position composite) ".")
718 (when composite "*")
719 (when (or position composite) " ")
720 (cond ((string= subtype "plain") type)
721 ((string= subtype "basic") type)
722 (t subtype))))
723 ;; Generate dissection information for this entity.
724 (push (list (incf nndoc-mime-split-ordinal)
725 head-begin head-end body-begin body-end
726 (count-lines body-begin body-end)
727 comment message-id references)
728 nndoc-dissection-alist)
729 ;; Recurse for all sub-entities, if any.
730 (goto-char head-begin)
731 (when (re-search-forward
732 (concat "\
733^Content-Type: *multipart/\\([a-z]+\\);\\(.*;\\)*"
734 "[ \t\n]*[ \t]boundary=\"?\\([^\"\n]*[^\" \t\n]\\)")
735 head-end t)
736 (let ((boundary (concat "\n--" (match-string 3) "\\(--\\)?[ \t]*\n"))
737 (part-counter 0)
738 begin end eof-flag)
739 (goto-char head-end)
740 (setq eof-flag (not (re-search-forward boundary body-end t)))
741 (while (not eof-flag)
742 (setq begin (point))
743 (cond ((re-search-forward boundary body-end t)
744 (or (not (match-string 1))
745 (string= (match-string 1) "")
746 (setq eof-flag t))
747 (forward-line -1)
748 (setq end (point))
749 (forward-line 1))
750 (t (setq end body-end
751 eof-flag t)))
752 (nndoc-dissect-mime-parts-sub begin end
753 (concat position (when position ".")
754 (format "%d"
755 (incf part-counter)))
756 (nnmail-message-id)
757 message-id)))))))
758
602;;;###autoload 759;;;###autoload
603(defun nndoc-add-type (definition &optional position) 760(defun nndoc-add-type (definition &optional position)
604 "Add document DEFINITION to the list of nndoc document definitions. 761 "Add document DEFINITION to the list of nndoc document definitions.
@@ -607,9 +764,7 @@ as the last checked definition, if t or `first', add as the
607first definition, and if any other symbol, add after that 764first definition, and if any other symbol, add after that
608symbol in the alist." 765symbol in the alist."
609 ;; First remove any old instances. 766 ;; First remove any old instances.
610 (setq nndoc-type-alist 767 (gnus-pull (car definition) nndoc-type-alist)
611 (delq (assq (car definition) nndoc-type-alist)
612 nndoc-type-alist))
613 ;; Then enter the new definition in the proper place. 768 ;; Then enter the new definition in the proper place.
614 (cond 769 (cond
615 ((or (null position) (eq position 'last)) 770 ((or (null position) (eq position 'last))
diff --git a/lisp/gnus/nndraft.el b/lisp/gnus/nndraft.el
index 5f2cb9afbe5..c6f23c41026 100644
--- a/lisp/gnus/nndraft.el
+++ b/lisp/gnus/nndraft.el
@@ -1,7 +1,7 @@
1;;; nndraft.el --- draft article access for Gnus 1;;; nndraft.el --- draft article access for Gnus
2;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. 2;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: news 5;; Keywords: news
6 6
7;; This file is part of GNU Emacs. 7;; This file is part of GNU Emacs.
@@ -26,22 +26,30 @@
26;;; Code: 26;;; Code:
27 27
28(require 'nnheader) 28(require 'nnheader)
29(require 'nnmail)
30(require 'gnus-start)
29(require 'nnmh) 31(require 'nnmh)
30(require 'nnoo) 32(require 'nnoo)
31(eval-and-compile (require 'cl)) 33(eval-when-compile
34 (require 'cl)
35 ;; This is just to shut up the byte-compiler.
36 (fset 'nndraft-request-group 'ignore))
32 37
33(nnoo-declare nndraft) 38(nnoo-declare nndraft
39 nnmh)
34 40
35(eval-and-compile 41(defvoo nndraft-directory (nnheader-concat gnus-directory "drafts/")
36 (autoload 'mail-send-and-exit "sendmail")) 42 "Where nndraft will store its files."
37 43 nnmh-directory)
38(defvoo nndraft-directory nil
39 "Where nndraft will store its directory.")
40 44
41 45
42 46
47(defvoo nndraft-current-group "" nil nnmh-current-group)
48(defvoo nndraft-get-new-mail nil nil nnmh-get-new-mail)
49(defvoo nndraft-current-directory nil nil nnmh-current-directory)
50
43(defconst nndraft-version "nndraft 1.0") 51(defconst nndraft-version "nndraft 1.0")
44(defvoo nndraft-status-string "") 52(defvoo nndraft-status-string "" nil nnmh-status-string)
45 53
46 54
47 55
@@ -49,7 +57,23 @@
49 57
50(nnoo-define-basics nndraft) 58(nnoo-define-basics nndraft)
51 59
60(deffoo nndraft-open-server (server &optional defs)
61 (nnoo-change-server 'nndraft server defs)
62 (cond
63 ((not (file-exists-p nndraft-directory))
64 (nndraft-close-server)
65 (nnheader-report 'nndraft "No such file or directory: %s"
66 nndraft-directory))
67 ((not (file-directory-p (file-truename nndraft-directory)))
68 (nndraft-close-server)
69 (nnheader-report 'nndraft "Not a directory: %s" nndraft-directory))
70 (t
71 (nnheader-report 'nndraft "Opened server %s using directory %s"
72 server nndraft-directory)
73 t)))
74
52(deffoo nndraft-retrieve-headers (articles &optional group server fetch-old) 75(deffoo nndraft-retrieve-headers (articles &optional group server fetch-old)
76 (nndraft-possibly-change-group group)
53 (save-excursion 77 (save-excursion
54 (set-buffer nntp-server-buffer) 78 (set-buffer nntp-server-buffer)
55 (erase-buffer) 79 (erase-buffer)
@@ -79,24 +103,8 @@
79 (nnheader-fold-continuation-lines) 103 (nnheader-fold-continuation-lines)
80 'headers)))) 104 'headers))))
81 105
82(deffoo nndraft-open-server (server &optional defs)
83 (nnoo-change-server 'nndraft server defs)
84 (unless (assq 'nndraft-directory defs)
85 (setq nndraft-directory server))
86 (cond
87 ((not (file-exists-p nndraft-directory))
88 (nndraft-close-server)
89 (nnheader-report 'nndraft "No such file or directory: %s"
90 nndraft-directory))
91 ((not (file-directory-p (file-truename nndraft-directory)))
92 (nndraft-close-server)
93 (nnheader-report 'nndraft "Not a directory: %s" nndraft-directory))
94 (t
95 (nnheader-report 'nndraft "Opened server %s using directory %s"
96 server nndraft-directory)
97 t)))
98
99(deffoo nndraft-request-article (id &optional group server buffer) 106(deffoo nndraft-request-article (id &optional group server buffer)
107 (nndraft-possibly-change-group group)
100 (when (numberp id) 108 (when (numberp id)
101 ;; We get the newest file of the auto-saved file and the 109 ;; We get the newest file of the auto-saved file and the
102 ;; "real" file. 110 ;; "real" file.
@@ -118,119 +126,92 @@
118 126
119(deffoo nndraft-request-restore-buffer (article &optional group server) 127(deffoo nndraft-request-restore-buffer (article &optional group server)
120 "Request a new buffer that is restored to the state of ARTICLE." 128 "Request a new buffer that is restored to the state of ARTICLE."
121 (let ((file (nndraft-article-filename article ".state")) 129 (nndraft-possibly-change-group group)
122 nndraft-point nndraft-mode nndraft-buffer-name) 130 (when (nndraft-request-article article group server (current-buffer))
123 (when (file-exists-p file) 131 (message-remove-header "xref")
124 (load file t t t) 132 (message-remove-header "lines")
125 (when nndraft-buffer-name 133 t))
126 (set-buffer (get-buffer-create
127 (generate-new-buffer-name nndraft-buffer-name)))
128 (nndraft-request-article article group server (current-buffer))
129 (funcall nndraft-mode)
130 (let ((gnus-verbose-backends nil))
131 (nndraft-request-expire-articles (list article) group server t))
132 (goto-char nndraft-point))
133 nndraft-buffer-name)))
134 134
135(deffoo nndraft-request-update-info (group info &optional server) 135(deffoo nndraft-request-update-info (group info &optional server)
136 (setcar (cddr info) nil) 136 (nndraft-possibly-change-group group)
137 (when (nth 3 info) 137 (gnus-info-set-read
138 (setcar (nthcdr 3 info) nil)) 138 info
139 (gnus-update-read-articles (gnus-group-prefixed-name group '(nndraft ""))
140 (nndraft-articles) t))
141 (let (marks)
142 (when (setq marks (nth 3 info))
143 (setcar (nthcdr 3 info)
144 (if (assq 'unsend marks)
145 (list (assq 'unsend marks))
146 nil))))
139 t) 147 t)
140 148
141(deffoo nndraft-request-associate-buffer (group) 149(deffoo nndraft-request-associate-buffer (group)
142 "Associate the current buffer with some article in the draft group." 150 "Associate the current buffer with some article in the draft group."
143 (let* ((gnus-verbose-backends nil) 151 (nndraft-open-server "")
144 (article (cdr (nndraft-request-accept-article 152 (nndraft-request-group group)
145 group (nnoo-current-server 'nndraft) t 'noinsert))) 153 (nndraft-possibly-change-group group)
146 (file (nndraft-article-filename article))) 154 (let ((gnus-verbose-backends nil)
147 (setq buffer-file-name file) 155 (buf (current-buffer))
156 article file)
157 (nnheader-temp-write nil
158 (insert-buffer buf)
159 (setq article (nndraft-request-accept-article
160 group (nnoo-current-server 'nndraft) t 'noinsert))
161 (setq file (nndraft-article-filename article)))
162 (setq buffer-file-name (expand-file-name file))
148 (setq buffer-auto-save-file-name (make-auto-save-file-name)) 163 (setq buffer-auto-save-file-name (make-auto-save-file-name))
149 (clear-visited-file-modtime) 164 (clear-visited-file-modtime)
150 article)) 165 article))
151 166
152(deffoo nndraft-request-group (group &optional server dont-check) 167(deffoo nndraft-request-expire-articles (articles group &optional server force)
153 (prog1 168 (nndraft-possibly-change-group group)
154 (nndraft-execute-nnmh-command 169 (let* ((nnmh-allow-delete-final t)
155 `(nnmh-request-group group "" ,dont-check)) 170 (res (nnoo-parent-function 'nndraft
156 (nnheader-report 'nndraft nnmh-status-string))) 171 'nnmh-request-expire-articles
157 172 (list articles group server force)))
158(deffoo nndraft-request-list (&optional server dir) 173 article)
159 (nndraft-execute-nnmh-command
160 `(nnmh-request-list nil ,dir)))
161
162(deffoo nndraft-request-newgroups (date &optional server)
163 (nndraft-execute-nnmh-command
164 `(nnmh-request-newgroups ,date ,server)))
165
166(deffoo nndraft-request-expire-articles
167 (articles group &optional server force)
168 (let ((res (nndraft-execute-nnmh-command
169 `(nnmh-request-expire-articles
170 ',articles group ,server ,force)))
171 article)
172 ;; Delete all the "state" files of articles that have been expired. 174 ;; Delete all the "state" files of articles that have been expired.
173 (while articles 175 (while articles
174 (unless (memq (setq article (pop articles)) res) 176 (unless (memq (setq article (pop articles)) res)
175 (let ((file (nndraft-article-filename article ".state")) 177 (let ((auto (nndraft-auto-save-file-name
176 (auto (nndraft-auto-save-file-name
177 (nndraft-article-filename article)))) 178 (nndraft-article-filename article))))
178 (when (file-exists-p file)
179 (funcall nnmail-delete-file-function file))
180 (when (file-exists-p auto) 179 (when (file-exists-p auto)
181 (funcall nnmail-delete-file-function auto))))) 180 (funcall nnmail-delete-file-function auto)))))
182 res)) 181 res))
183 182
184(deffoo nndraft-request-accept-article (group &optional server last noinsert) 183(deffoo nndraft-request-accept-article (group &optional server last noinsert)
185 (let* ((point (point)) 184 (nndraft-possibly-change-group group)
186 (mode major-mode) 185 (let ((gnus-verbose-backends nil))
187 (name (buffer-name)) 186 (nnoo-parent-function 'nndraft 'nnmh-request-accept-article
188 (gnus-verbose-backends nil) 187 (list group server last noinsert))))
189 (gart (nndraft-execute-nnmh-command
190 `(nnmh-request-accept-article group ,server ,last noinsert)))
191 (state
192 (nndraft-article-filename (cdr gart) ".state")))
193 ;; Write the "state" file.
194 (save-excursion
195 (nnheader-set-temp-buffer " *draft state*")
196 (insert (format "%S\n" `(setq nndraft-mode (quote ,mode)
197 nndraft-point ,point
198 nndraft-buffer-name ,name)))
199 (write-region (point-min) (point-max) state nil 'silent)
200 (kill-buffer (current-buffer)))
201 gart))
202
203(deffoo nndraft-close-group (group &optional server)
204 t)
205 188
206(deffoo nndraft-request-create-group (group &optional server args) 189(deffoo nndraft-request-create-group (group &optional server args)
207 (if (file-exists-p nndraft-directory) 190 (nndraft-possibly-change-group group)
208 (if (file-directory-p nndraft-directory) 191 (if (file-exists-p nndraft-current-directory)
192 (if (file-directory-p nndraft-current-directory)
209 t 193 t
210 nil) 194 nil)
211 (condition-case () 195 (condition-case ()
212 (progn 196 (progn
213 (gnus-make-directory nndraft-directory) 197 (gnus-make-directory nndraft-current-directory)
214 t) 198 t)
215 (file-error nil)))) 199 (file-error nil))))
216 200
217 201
218;;; Low-Level Interface 202;;; Low-Level Interface
219 203
220(defun nndraft-execute-nnmh-command (command) 204(defun nndraft-possibly-change-group (group)
221 (let ((dir (expand-file-name nndraft-directory))) 205 (when (and group
222 (when (string-match "/$" dir) 206 (not (equal group nndraft-current-group)))
223 (setq dir (substring dir 0 (match-beginning 0)))) 207 (nndraft-open-server "")
224 (string-match "/[^/]+$" dir) 208 (setq nndraft-current-group group)
225 (let ((group (substring dir (1+ (match-beginning 0)))) 209 (setq nndraft-current-directory
226 (nnmh-directory (substring dir 0 (1+ (match-beginning 0)))) 210 (nnheader-concat nndraft-directory group))))
227 (nnmail-keep-last-article nil)
228 (nnmh-get-new-mail nil))
229 (eval command))))
230 211
231(defun nndraft-article-filename (article &rest args) 212(defun nndraft-article-filename (article &rest args)
232 (apply 'concat 213 (apply 'concat
233 (file-name-as-directory nndraft-directory) 214 (file-name-as-directory nndraft-current-directory)
234 (int-to-string article) 215 (int-to-string article)
235 args)) 216 args))
236 217
@@ -243,6 +224,24 @@
243 (make-auto-save-file-name)) 224 (make-auto-save-file-name))
244 (kill-buffer (current-buffer))))) 225 (kill-buffer (current-buffer)))))
245 226
227(defun nndraft-articles ()
228 "Return the list of messages in the group."
229 (gnus-make-directory nndraft-current-directory)
230 (sort
231 (mapcar 'string-to-int
232 (directory-files nndraft-current-directory nil "\\`[0-9]+\\'" t))
233 '<))
234
235(nnoo-import nndraft
236 (nnmh
237 nnmh-retrieve-headers
238 nnmh-request-group
239 nnmh-close-group
240 nnmh-request-list
241 nnmh-request-newsgroups
242 nnmh-request-move-article
243 nnmh-request-replace-article))
244
246(provide 'nndraft) 245(provide 'nndraft)
247 246
248;;; nndraft.el ends here 247;;; nndraft.el ends here
diff --git a/lisp/gnus/nneething.el b/lisp/gnus/nneething.el
index b04d5b36294..7da54665884 100644
--- a/lisp/gnus/nneething.el
+++ b/lisp/gnus/nneething.el
@@ -1,7 +1,7 @@
1;;; nneething.el --- random file access for Gnus 1;;; nneething.el --- arbitrary file access for Gnus
2;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. 2;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> 5;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
6;; Keywords: news, mail 6;; Keywords: news, mail
7 7
@@ -64,9 +64,12 @@ If this variable is nil, no files will be excluded.")
64(defvoo nneething-map nil) 64(defvoo nneething-map nil)
65(defvoo nneething-read-only nil) 65(defvoo nneething-read-only nil)
66(defvoo nneething-active nil) 66(defvoo nneething-active nil)
67(defvoo nneething-address nil)
67 68
68 69
69 70
71(autoload 'gnus-encode-coding-string "gnus-ems")
72
70;;; Interface functions. 73;;; Interface functions.
71 74
72(nnoo-define-basics nneething) 75(nnoo-define-basics nneething)
@@ -100,11 +103,11 @@ If this variable is nil, no files will be excluded.")
100 103
101 (and large 104 (and large
102 (zerop (% count 20)) 105 (zerop (% count 20))
103 (message "nneething: Receiving headers... %d%%" 106 (nnheader-message 5 "nneething: Receiving headers... %d%%"
104 (/ (* count 100) number)))) 107 (/ (* count 100) number))))
105 108
106 (when large 109 (when large
107 (message "nneething: Receiving headers...done")) 110 (nnheader-message 5 "nneething: Receiving headers...done"))
108 111
109 (nnheader-fold-continuation-lines) 112 (nnheader-fold-continuation-lines)
110 'headers)))) 113 'headers))))
@@ -155,8 +158,8 @@ If this variable is nil, no files will be excluded.")
155 (nnheader-init-server-buffer) 158 (nnheader-init-server-buffer)
156 (if (nneething-server-opened server) 159 (if (nneething-server-opened server)
157 t 160 t
158 (unless (assq 'nneething-directory defs) 161 (unless (assq 'nneething-address defs)
159 (setq defs (append defs (list (list 'nneething-directory server))))) 162 (setq defs (append defs (list (list 'nneething-address server)))))
160 (nnoo-change-server 'nneething server defs))) 163 (nnoo-change-server 'nneething server defs)))
161 164
162 165
@@ -182,9 +185,9 @@ If this variable is nil, no files will be excluded.")
182 185
183(defun nneething-create-mapping () 186(defun nneething-create-mapping ()
184 ;; Read nneething-active and nneething-map. 187 ;; Read nneething-active and nneething-map.
185 (when (file-exists-p nneething-directory) 188 (when (file-exists-p nneething-address)
186 (let ((map-file (nneething-map-file)) 189 (let ((map-file (nneething-map-file))
187 (files (directory-files nneething-directory)) 190 (files (directory-files nneething-address))
188 touched map-files) 191 touched map-files)
189 (when (file-exists-p map-file) 192 (when (file-exists-p map-file)
190 (ignore-errors 193 (ignore-errors
@@ -341,7 +344,7 @@ If this variable is nil, no files will be excluded.")
341 344
342(defun nneething-file-name (article) 345(defun nneething-file-name (article)
343 "Return the file name of ARTICLE." 346 "Return the file name of ARTICLE."
344 (concat (file-name-as-directory nneething-directory) 347 (concat (file-name-as-directory nneething-address)
345 (if (numberp article) 348 (if (numberp article)
346 (cadr (assq article nneething-map)) 349 (cadr (assq article nneething-map))
347 article))) 350 article)))
diff --git a/lisp/gnus/nnfolder.el b/lisp/gnus/nnfolder.el
index c7f9a720ff2..fb14056af93 100644
--- a/lisp/gnus/nnfolder.el
+++ b/lisp/gnus/nnfolder.el
@@ -1,8 +1,8 @@
1;;; nnfolder.el --- mail folder access for Gnus 1;;; nnfolder.el --- mail folder access for Gnus
2;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. 2;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Scott Byer <byer@mv.us.adobe.com> 4;; Author: Scott Byer <byer@mv.us.adobe.com>
5;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 5;; Lars Magne Ingebrigtsen <larsi@gnus.org>
6;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> 6;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
7;; Keywords: mail 7;; Keywords: mail
8 8
@@ -31,7 +31,7 @@
31(require 'message) 31(require 'message)
32(require 'nnmail) 32(require 'nnmail)
33(require 'nnoo) 33(require 'nnoo)
34(require 'cl) 34(eval-when-compile (require 'cl))
35(require 'gnus-util) 35(require 'gnus-util)
36 36
37(nnoo-declare nnfolder) 37(nnoo-declare nnfolder)
@@ -101,24 +101,16 @@ time saver for large mailboxes.")
101 (save-excursion 101 (save-excursion
102 (set-buffer nntp-server-buffer) 102 (set-buffer nntp-server-buffer)
103 (erase-buffer) 103 (erase-buffer)
104 (let (article art-string start stop) 104 (let (article start stop)
105 (nnfolder-possibly-change-group group server) 105 (nnfolder-possibly-change-group group server)
106 (when nnfolder-current-buffer 106 (when nnfolder-current-buffer
107 (set-buffer nnfolder-current-buffer) 107 (set-buffer nnfolder-current-buffer)
108 (goto-char (point-min)) 108 (goto-char (point-min))
109 (if (stringp (car articles)) 109 (if (stringp (car articles))
110 'headers 110 'headers
111 (while articles 111 (while (setq article (pop articles))
112 (setq article (car articles))
113 (setq art-string (nnfolder-article-string article))
114 (set-buffer nnfolder-current-buffer) 112 (set-buffer nnfolder-current-buffer)
115 (when (or (search-forward art-string nil t) 113 (when (nnfolder-goto-article article)
116 ;; Don't search the whole file twice! Also, articles
117 ;; probably have some locality by number, so searching
118 ;; backwards will be faster. Especially if we're at the
119 ;; beginning of the buffer :-). -SLB
120 (search-backward art-string nil t))
121 (nnmail-search-unix-mail-delim-backward)
122 (setq start (point)) 114 (setq start (point))
123 (search-forward "\n\n" nil t) 115 (search-forward "\n\n" nil t)
124 (setq stop (1- (point))) 116 (setq stop (1- (point)))
@@ -126,8 +118,7 @@ time saver for large mailboxes.")
126 (insert (format "221 %d Article retrieved.\n" article)) 118 (insert (format "221 %d Article retrieved.\n" article))
127 (insert-buffer-substring nnfolder-current-buffer start stop) 119 (insert-buffer-substring nnfolder-current-buffer start stop)
128 (goto-char (point-max)) 120 (goto-char (point-max))
129 (insert ".\n")) 121 (insert ".\n")))
130 (setq articles (cdr articles)))
131 122
132 (set-buffer nntp-server-buffer) 123 (set-buffer nntp-server-buffer)
133 (nnheader-fold-continuation-lines) 124 (nnheader-fold-continuation-lines)
@@ -165,9 +156,8 @@ time saver for large mailboxes.")
165 (save-excursion 156 (save-excursion
166 (set-buffer nnfolder-current-buffer) 157 (set-buffer nnfolder-current-buffer)
167 (goto-char (point-min)) 158 (goto-char (point-min))
168 (when (search-forward (nnfolder-article-string article) nil t) 159 (when (nnfolder-goto-article article)
169 (let (start stop) 160 (let (start stop)
170 (nnmail-search-unix-mail-delim-backward)
171 (setq start (point)) 161 (setq start (point))
172 (forward-line 1) 162 (forward-line 1)
173 (unless (and (nnmail-search-unix-mail-delim) 163 (unless (and (nnmail-search-unix-mail-delim)
@@ -283,11 +273,8 @@ time saver for large mailboxes.")
283(deffoo nnfolder-request-list (&optional server) 273(deffoo nnfolder-request-list (&optional server)
284 (nnfolder-possibly-change-group nil server) 274 (nnfolder-possibly-change-group nil server)
285 (save-excursion 275 (save-excursion
286 ;; 1997/8/14 by MORIOKA Tomohiko
287 ;; for XEmacs/mule.
288 (let ((nnmail-file-coding-system nnmail-active-file-coding-system) 276 (let ((nnmail-file-coding-system nnmail-active-file-coding-system)
289 (file-name-coding-system 'binary) ; for Emacs 20 277 (pathname-coding-system 'binary))
290 (pathname-coding-system 'binary)) ; for XEmacs/mule
291 (nnmail-find-file nnfolder-active-file) 278 (nnmail-find-file nnfolder-active-file)
292 (setq nnfolder-group-alist (nnmail-get-active))) 279 (setq nnfolder-group-alist (nnmail-get-active)))
293 t)) 280 t))
@@ -312,7 +299,7 @@ time saver for large mailboxes.")
312 (set-buffer nnfolder-current-buffer) 299 (set-buffer nnfolder-current-buffer)
313 (while (and articles is-old) 300 (while (and articles is-old)
314 (goto-char (point-min)) 301 (goto-char (point-min))
315 (when (search-forward (nnfolder-article-string (car articles)) nil t) 302 (when (nnfolder-goto-article (car articles))
316 (if (setq is-old 303 (if (setq is-old
317 (nnmail-expired-article-p 304 (nnmail-expired-article-p
318 newsgroup 305 newsgroup
@@ -332,85 +319,99 @@ time saver for large mailboxes.")
332 (nnmail-save-active nnfolder-group-alist nnfolder-active-file) 319 (nnmail-save-active nnfolder-group-alist nnfolder-active-file)
333 (nconc rest articles)))) 320 (nconc rest articles))))
334 321
335(deffoo nnfolder-request-move-article 322(deffoo nnfolder-request-move-article (article group server
336 (article group server accept-form &optional last) 323 accept-form &optional last)
337 (let ((buf (get-buffer-create " *nnfolder move*")) 324 (save-excursion
338 result) 325 (let ((buf (get-buffer-create " *nnfolder move*"))
339 (and 326 result)
340 (nnfolder-request-article article group server) 327 (and
341 (save-excursion 328 (nnfolder-request-article article group server)
342 (set-buffer buf) 329 (save-excursion
343 (buffer-disable-undo (current-buffer)) 330 (set-buffer buf)
344 (erase-buffer) 331 (buffer-disable-undo (current-buffer))
345 (insert-buffer-substring nntp-server-buffer) 332 (erase-buffer)
346 (goto-char (point-min)) 333 (insert-buffer-substring nntp-server-buffer)
347 (while (re-search-forward 334 (goto-char (point-min))
348 (concat "^" nnfolder-article-marker) 335 (while (re-search-forward
349 (save-excursion (search-forward "\n\n" nil t) (point)) t) 336 (concat "^" nnfolder-article-marker)
350 (delete-region (progn (beginning-of-line) (point)) 337 (save-excursion (search-forward "\n\n" nil t) (point)) t)
351 (progn (forward-line 1) (point)))) 338 (delete-region (progn (beginning-of-line) (point))
352 (setq result (eval accept-form)) 339 (progn (forward-line 1) (point))))
353 (kill-buffer buf) 340 (setq result (eval accept-form))
354 result) 341 (kill-buffer buf)
355 (save-excursion 342 result)
356 (nnfolder-possibly-change-group group server) 343 (save-excursion
357 (set-buffer nnfolder-current-buffer) 344 (nnfolder-possibly-change-group group server)
358 (goto-char (point-min)) 345 (set-buffer nnfolder-current-buffer)
359 (when (search-forward (nnfolder-article-string article) nil t) 346 (goto-char (point-min))
360 (nnfolder-delete-mail)) 347 (when (nnfolder-goto-article article)
361 (when last 348 (nnfolder-delete-mail))
362 (nnfolder-save-buffer) 349 (when last
363 (nnfolder-adjust-min-active group) 350 (nnfolder-save-buffer)
364 (nnmail-save-active nnfolder-group-alist nnfolder-active-file)))) 351 (nnfolder-adjust-min-active group)
365 result)) 352 (nnmail-save-active nnfolder-group-alist nnfolder-active-file))))
353 result)))
366 354
367(deffoo nnfolder-request-accept-article (group &optional server last) 355(deffoo nnfolder-request-accept-article (group &optional server last)
368 (nnfolder-possibly-change-group group server) 356 (save-excursion
369 (nnmail-check-syntax) 357 (nnfolder-possibly-change-group group server)
370 (let ((buf (current-buffer)) 358 (nnmail-check-syntax)
371 result art-group) 359 (let ((buf (current-buffer))
372 (goto-char (point-min)) 360 result art-group)
373 (when (looking-at "X-From-Line: ") 361 (goto-char (point-min))
374 (replace-match "From ")) 362 (when (looking-at "X-From-Line: ")
375 (and 363 (replace-match "From "))
376 (nnfolder-request-list) 364 (and
377 (save-excursion 365 (nnfolder-request-list)
378 (set-buffer buf)
379 (goto-char (point-min))
380 (search-forward "\n\n" nil t)
381 (forward-line -1)
382 (while (re-search-backward (concat "^" nnfolder-article-marker) nil t)
383 (delete-region (point) (progn (forward-line 1) (point))))
384 (when nnmail-cache-accepted-message-ids
385 (nnmail-cache-insert (nnmail-fetch-field "message-id")))
386 (setq result (if (stringp group)
387 (list (cons group (nnfolder-active-number group)))
388 (setq art-group
389 (nnmail-article-group 'nnfolder-active-number))))
390 (if (and (null result)
391 (yes-or-no-p "Moved to `junk' group; delete article? "))
392 (setq result 'junk)
393 (setq result
394 (car (nnfolder-save-mail result)))))
395 (when last
396 (save-excursion 366 (save-excursion
397 (nnfolder-possibly-change-folder (or (caar art-group) group)) 367 (set-buffer buf)
398 (nnfolder-save-buffer) 368 (goto-char (point-min))
369 (search-forward "\n\n" nil t)
370 (forward-line -1)
371 (while (re-search-backward (concat "^" nnfolder-article-marker) nil t)
372 (delete-region (point) (progn (forward-line 1) (point))))
399 (when nnmail-cache-accepted-message-ids 373 (when nnmail-cache-accepted-message-ids
400 (nnmail-cache-close))))) 374 (nnmail-cache-insert (nnmail-fetch-field "message-id")))
401 (nnmail-save-active nnfolder-group-alist nnfolder-active-file) 375 (setq result (if (stringp group)
402 (unless result 376 (list (cons group (nnfolder-active-number group)))
403 (nnheader-report 'nnfolder "Couldn't store article")) 377 (setq art-group
404 result)) 378 (nnmail-article-group 'nnfolder-active-number))))
379 (if (and (null result)
380 (yes-or-no-p "Moved to `junk' group; delete article? "))
381 (setq result 'junk)
382 (setq result
383 (car (nnfolder-save-mail result)))))
384 (when last
385 (save-excursion
386 (nnfolder-possibly-change-folder (or (caar art-group) group))
387 (nnfolder-save-buffer)
388 (when nnmail-cache-accepted-message-ids
389 (nnmail-cache-close)))))
390 (nnmail-save-active nnfolder-group-alist nnfolder-active-file)
391 (unless result
392 (nnheader-report 'nnfolder "Couldn't store article"))
393 result)))
405 394
406(deffoo nnfolder-request-replace-article (article group buffer) 395(deffoo nnfolder-request-replace-article (article group buffer)
407 (nnfolder-possibly-change-group group) 396 (nnfolder-possibly-change-group group)
408 (save-excursion 397 (save-excursion
398 (set-buffer buffer)
399 (goto-char (point-min))
400 (let (xfrom)
401 (while (re-search-forward "^X-From-Line: \\(.*\\)$" nil t)
402 (setq xfrom (match-string 1))
403 (gnus-delete-line))
404 (goto-char (point-min))
405 (if xfrom
406 (insert "From " xfrom "\n")
407 (unless (looking-at message-unix-mail-delimiter)
408 (insert "From nobody " (current-time-string) "\n"))))
409 (nnfolder-normalize-buffer)
409 (set-buffer nnfolder-current-buffer) 410 (set-buffer nnfolder-current-buffer)
410 (goto-char (point-min)) 411 (goto-char (point-min))
411 (if (not (search-forward (nnfolder-article-string article) nil t)) 412 (if (not (nnfolder-goto-article article))
412 nil 413 nil
413 (nnfolder-delete-mail t t) 414 (nnfolder-delete-mail)
414 (insert-buffer-substring buffer) 415 (insert-buffer-substring buffer)
415 (nnfolder-save-buffer) 416 (nnfolder-save-buffer)
416 t))) 417 t)))
@@ -472,10 +473,9 @@ time saver for large mailboxes.")
472 (goto-char (point-min)) 473 (goto-char (point-min))
473 (while (and (search-forward marker nil t) 474 (while (and (search-forward marker nil t)
474 (re-search-forward number nil t)) 475 (re-search-forward number nil t))
475 (setq activemin (min activemin 476 (let ((newnum (string-to-number (match-string 0))))
476 (string-to-number (buffer-substring 477 (if (nnmail-within-headers-p)
477 (match-beginning 0) 478 (setq activemin (min activemin newnum)))))
478 (match-end 0))))))
479 (setcar active activemin)))) 479 (setcar active activemin))))
480 480
481(defun nnfolder-article-string (article) 481(defun nnfolder-article-string (article)
@@ -483,21 +483,45 @@ time saver for large mailboxes.")
483 (concat "\n" nnfolder-article-marker (int-to-string article) " ") 483 (concat "\n" nnfolder-article-marker (int-to-string article) " ")
484 (concat "\nMessage-ID: " article))) 484 (concat "\nMessage-ID: " article)))
485 485
486(defun nnfolder-delete-mail (&optional force leave-delim) 486(defun nnfolder-goto-article (article)
487 "Delete the message that point is in." 487 "Place point at the start of the headers of ARTICLE.
488 (save-excursion 488ARTICLE can be an article number or a Message-ID.
489 (delete-region 489Returns t if successful, nil otherwise."
490 (save-excursion 490 (let ((art-string (nnfolder-article-string article))
491 (nnmail-search-unix-mail-delim-backward) 491 start found)
492 (if leave-delim (progn (forward-line 1) (point)) 492 ;; It is likely that we are at or before the delimiter line.
493 (point))) 493 ;; We therefore go to the end of the previous line, and start
494 (progn 494 ;; searching from there.
495 (forward-line 1) 495 (beginning-of-line)
496 (if (nnmail-search-unix-mail-delim) 496 (unless (bobp)
497 (if (and (not (bobp)) leave-delim) 497 (forward-char -1))
498 (progn (forward-line -2) (point)) 498 (setq start (point))
499 (point)) 499 ;; First search forward.
500 (point-max)))))) 500 (while (and (setq found (search-forward art-string nil t))
501 (not (nnmail-within-headers-p))))
502 ;; If unsuccessful, search backward from where we started,
503 (unless found
504 (goto-char start)
505 (while (and (setq found (search-backward art-string nil t))
506 (not (nnmail-within-headers-p)))))
507 (when found
508 (nnmail-search-unix-mail-delim-backward))))
509
510(defun nnfolder-delete-mail (&optional leave-delim)
511 "Delete the message that point is in.
512If optional argument LEAVE-DELIM is t, then mailbox delimiter is not
513deleted. Point is left where the deleted region was."
514 (delete-region
515 (save-excursion
516 (forward-line 1) ; in case point is at beginning of message already
517 (nnmail-search-unix-mail-delim-backward)
518 (if leave-delim (progn (forward-line 1) (point))
519 (point)))
520 (progn
521 (forward-line 1)
522 (if (nnmail-search-unix-mail-delim)
523 (point)
524 (point-max)))))
501 525
502(defun nnfolder-possibly-change-group (group &optional server dont-check) 526(defun nnfolder-possibly-change-group (group &optional server dont-check)
503 ;; Change servers. 527 ;; Change servers.
@@ -541,7 +565,8 @@ time saver for large mailboxes.")
541 (setq nnfolder-current-group group) 565 (setq nnfolder-current-group group)
542 566
543 (when (or (not nnfolder-current-buffer) 567 (when (or (not nnfolder-current-buffer)
544 (not (verify-visited-file-modtime nnfolder-current-buffer))) 568 (not (verify-visited-file-modtime
569 nnfolder-current-buffer)))
545 (save-excursion 570 (save-excursion
546 (setq file (nnfolder-group-pathname group)) 571 (setq file (nnfolder-group-pathname group))
547 ;; See whether we need to create the new file. 572 ;; See whether we need to create the new file.
@@ -564,8 +589,13 @@ time saver for large mailboxes.")
564 (unless (looking-at message-unix-mail-delimiter) 589 (unless (looking-at message-unix-mail-delimiter)
565 (insert "From nobody " (current-time-string) "\n") 590 (insert "From nobody " (current-time-string) "\n")
566 (goto-char (point-min))) 591 (goto-char (point-min)))
567 ;; Quote all "From " lines in the article.
568 (forward-line 1) 592 (forward-line 1)
593 ;; Quote subsequent "From " lines in the header.
594 (while (looking-at message-unix-mail-delimiter)
595 (delete-region (point) (+ (point) 4))
596 (insert "X-From-Line:")
597 (forward-line 1))
598 ;; Quote all "From " lines in the article.
569 (let (case-fold-search) 599 (let (case-fold-search)
570 (while (re-search-forward "^From " nil t) 600 (while (re-search-forward "^From " nil t)
571 (beginning-of-line) 601 (beginning-of-line)
@@ -594,16 +624,19 @@ time saver for large mailboxes.")
594 (obuf (current-buffer))) 624 (obuf (current-buffer)))
595 (nnfolder-possibly-change-folder (car group-art)) 625 (nnfolder-possibly-change-folder (car group-art))
596 (let ((buffer-read-only nil)) 626 (let ((buffer-read-only nil))
597 (goto-char (point-max)) 627 (nnfolder-normalize-buffer)
598 (unless (eolp)
599 (insert "\n"))
600 (unless (bobp)
601 (insert "\n"))
602 (insert-buffer-substring obuf beg end))))) 628 (insert-buffer-substring obuf beg end)))))
603 629
604 ;; Did we save it anywhere? 630 ;; Did we save it anywhere?
605 save-list)) 631 save-list))
606 632
633(defun nnfolder-normalize-buffer ()
634 "Make sure there are two newlines at the end of the buffer."
635 (goto-char (point-max))
636 (skip-chars-backward "\n")
637 (delete-region (point) (point-max))
638 (insert "\n\n"))
639
607(defun nnfolder-insert-newsgroup-line (group-art) 640(defun nnfolder-insert-newsgroup-line (group-art)
608 (save-excursion 641 (save-excursion
609 (goto-char (point-min)) 642 (goto-char (point-min))
@@ -657,7 +690,11 @@ time saver for large mailboxes.")
657 (if (equal (cadr (assoc group nnfolder-scantime-alist)) 690 (if (equal (cadr (assoc group nnfolder-scantime-alist))
658 (nth 5 (file-attributes file))) 691 (nth 5 (file-attributes file)))
659 ;; This looks up-to-date, so we don't do any scanning. 692 ;; This looks up-to-date, so we don't do any scanning.
660 buffer 693 (if (file-exists-p file)
694 buffer
695 (push (list group buffer) nnfolder-buffer-alist)
696 (set-buffer-modified-p t)
697 (save-buffer))
661 ;; Parse the damn thing. 698 ;; Parse the damn thing.
662 (save-excursion 699 (save-excursion
663 (nnmail-activate 'nnfolder) 700 (nnmail-activate 'nnfolder)
@@ -686,8 +723,9 @@ time saver for large mailboxes.")
686 (while (and (search-forward marker nil t) 723 (while (and (search-forward marker nil t)
687 (re-search-forward number nil t)) 724 (re-search-forward number nil t))
688 (let ((newnum (string-to-number (match-string 0)))) 725 (let ((newnum (string-to-number (match-string 0))))
689 (setq maxid (max maxid newnum)) 726 (if (nnmail-within-headers-p)
690 (setq minid (min minid newnum)))) 727 (setq maxid (max maxid newnum)
728 minid (min minid newnum)))))
691 (setcar active (max 1 (min minid maxid))) 729 (setcar active (max 1 (min minid maxid)))
692 (setcdr active (max maxid (cdr active))) 730 (setcdr active (max maxid (cdr active)))
693 (goto-char (point-min))) 731 (goto-char (point-min)))
@@ -761,7 +799,7 @@ time saver for large mailboxes.")
761 (nnfolder-possibly-change-folder file) 799 (nnfolder-possibly-change-folder file)
762 (nnfolder-possibly-change-group file) 800 (nnfolder-possibly-change-group file)
763 (nnfolder-close-group file)))) 801 (nnfolder-close-group file))))
764 (message ""))) 802 (nnheader-message 5 "")))
765 803
766(defun nnfolder-group-pathname (group) 804(defun nnfolder-group-pathname (group)
767 "Make pathname for GROUP." 805 "Make pathname for GROUP."
diff --git a/lisp/gnus/nngateway.el b/lisp/gnus/nngateway.el
index 5888d48b272..c580ac55309 100644
--- a/lisp/gnus/nngateway.el
+++ b/lisp/gnus/nngateway.el
@@ -1,7 +1,7 @@
1;;; nngateway.el --- posting news via mail gateways 1;;; nngateway.el --- posting news via mail gateways
2;; Copyright (C) 1996,97 Free Software Foundation, Inc. 2;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: news, mail 5;; Keywords: news, mail
6 6
7;; This file is part of GNU Emacs. 7;; This file is part of GNU Emacs.
@@ -63,7 +63,8 @@ parameter -- the gateway address.")
63 (insert mail-header-separator "\n") 63 (insert mail-header-separator "\n")
64 (widen) 64 (widen)
65 (let (message-required-mail-headers) 65 (let (message-required-mail-headers)
66 (funcall message-send-mail-function)))))) 66 (funcall message-send-mail-function))
67 t))))
67 68
68;;; Internal functions 69;;; Internal functions
69 70
@@ -76,6 +77,13 @@ parameter -- the gateway address.")
76 (insert "To: " (nnheader-replace-chars-in-string newsgroups ?. ?-) 77 (insert "To: " (nnheader-replace-chars-in-string newsgroups ?. ?-)
77 "@" gateway "\n"))) 78 "@" gateway "\n")))
78 79
80(defun nngateway-mail2news-header-transformation (gateway)
81 "Transform the headers for sending to a mail2news gateway."
82 (message-remove-header "to")
83 (message-remove-header "cc")
84 (goto-char (point-min))
85 (insert "To: " gateway "\n"))
86
79(nnoo-define-skeleton nngateway) 87(nnoo-define-skeleton nngateway)
80 88
81(provide 'nngateway) 89(provide 'nngateway)
diff --git a/lisp/gnus/nnheader.el b/lisp/gnus/nnheader.el
index 448fb8252e1..395a2085e00 100644
--- a/lisp/gnus/nnheader.el
+++ b/lisp/gnus/nnheader.el
@@ -1,8 +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 Free Software Foundation, Inc. 2;; Copyright (C) 1987,88,89,90,93,94,95,96,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> 4;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
5;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 5;; Lars Magne Ingebrigtsen <larsi@gnus.org>
6;; Keywords: news 6;; Keywords: news
7 7
8;; This file is part of GNU Emacs. 8;; This file is part of GNU Emacs.
@@ -39,6 +39,8 @@
39 39
40(eval-when-compile (require 'cl)) 40(eval-when-compile (require 'cl))
41 41
42(eval-when-compile (require 'cl))
43
42(require 'mail-utils) 44(require 'mail-utils)
43 45
44(defvar nnheader-max-head-length 4096 46(defvar nnheader-max-head-length 4096
@@ -59,7 +61,10 @@ on your system, you could say something like:
59 (autoload 'mail-position-on-field "sendmail") 61 (autoload 'mail-position-on-field "sendmail")
60 (autoload 'message-remove-header "message") 62 (autoload 'message-remove-header "message")
61 (autoload 'cancel-function-timers "timers") 63 (autoload 'cancel-function-timers "timers")
62 (autoload 'gnus-point-at-eol "gnus-util")) 64 (autoload 'gnus-point-at-eol "gnus-util")
65 (autoload 'gnus-delete-line "gnus-util")
66 (autoload 'gnus-buffer-live-p "gnus-util")
67 (autoload 'gnus-encode-coding-string "gnus-ems"))
63 68
64;;; Header access macros. 69;;; Header access macros.
65 70
@@ -166,7 +171,7 @@ on your system, you could say something like:
166 (let ((case-fold-search t) 171 (let ((case-fold-search t)
167 (cur (current-buffer)) 172 (cur (current-buffer))
168 (buffer-read-only nil) 173 (buffer-read-only nil)
169 in-reply-to lines p) 174 in-reply-to lines p ref)
170 (goto-char (point-min)) 175 (goto-char (point-min))
171 (when naked 176 (when naked
172 (insert "\n")) 177 (insert "\n"))
@@ -214,8 +219,9 @@ on your system, you could say something like:
214 (goto-char p) 219 (goto-char p)
215 (if (search-forward "\nmessage-id:" nil t) 220 (if (search-forward "\nmessage-id:" nil t)
216 (buffer-substring 221 (buffer-substring
217 (1- (or (search-forward "<" nil t) (point))) 222 (1- (or (search-forward "<" (gnus-point-at-eol) t)
218 (or (search-forward ">" nil t) (point))) 223 (point)))
224 (or (search-forward ">" (gnus-point-at-eol) t) (point)))
219 ;; If there was no message-id, we just fake one to make 225 ;; If there was no message-id, we just fake one to make
220 ;; subsequent routines simpler. 226 ;; subsequent routines simpler.
221 (nnheader-generate-fake-message-id))) 227 (nnheader-generate-fake-message-id)))
@@ -230,9 +236,16 @@ on your system, you could say something like:
230 (if (and (search-forward "\nin-reply-to: " nil t) 236 (if (and (search-forward "\nin-reply-to: " nil t)
231 (setq in-reply-to (nnheader-header-value)) 237 (setq in-reply-to (nnheader-header-value))
232 (string-match "<[^>]+>" in-reply-to)) 238 (string-match "<[^>]+>" in-reply-to))
233 (substring in-reply-to (match-beginning 0) 239 (let (ref2)
234 (match-end 0)) 240 (setq ref (substring in-reply-to (match-beginning 0)
235 ""))) 241 (match-end 0)))
242 (while (string-match "<[^>]+>" in-reply-to (match-end 0))
243 (setq ref2 (substring in-reply-to (match-beginning 0)
244 (match-end 0)))
245 (when (> (length ref2) (length ref))
246 (setq ref ref2)))
247 ref)
248 nil)))
236 ;; Chars. 249 ;; Chars.
237 0 250 0
238 ;; Lines. 251 ;; Lines.
@@ -341,7 +354,10 @@ the line could be found."
341 (eobp)) 354 (eobp))
342 (setq found t) 355 (setq found t)
343 (setq prev (point)) 356 (setq prev (point))
344 (cond ((> (setq num (read cur)) article) 357 (while (and (not (numberp (setq num (read cur))))
358 (not (eobp)))
359 (gnus-delete-line))
360 (cond ((> num article)
345 (setq max (point))) 361 (setq max (point)))
346 ((< num article) 362 ((< num article)
347 (setq min (point))) 363 (setq min (point)))
@@ -386,7 +402,6 @@ the line could be found."
386 (unless (gnus-buffer-live-p nntp-server-buffer) 402 (unless (gnus-buffer-live-p nntp-server-buffer)
387 (setq nntp-server-buffer (get-buffer-create " *nntpd*"))) 403 (setq nntp-server-buffer (get-buffer-create " *nntpd*")))
388 (set-buffer nntp-server-buffer) 404 (set-buffer nntp-server-buffer)
389 (buffer-disable-undo (current-buffer))
390 (erase-buffer) 405 (erase-buffer)
391 (kill-all-local-variables) 406 (kill-all-local-variables)
392 (setq case-fold-search t) ;Should ignore case. 407 (setq case-fold-search t) ;Should ignore case.
@@ -549,7 +564,7 @@ If FILE is t, return the buffer contents as a string."
549 564
550(defsubst nnheader-file-to-number (file) 565(defsubst nnheader-file-to-number (file)
551 "Take a file name and return the article number." 566 "Take a file name and return the article number."
552 (if (not (boundp 'jka-compr-compression-info-list)) 567 (if (string= nnheader-numerical-short-files "^[0-9]+$")
553 (string-to-int file) 568 (string-to-int file)
554 (string-match nnheader-numerical-short-files file) 569 (string-match nnheader-numerical-short-files file)
555 (string-to-int (match-string 0 file)))) 570 (string-to-int (match-string 0 file))))
@@ -581,21 +596,27 @@ If FILE is t, return the buffer contents as a string."
581 "Fold continuation lines in the current buffer." 596 "Fold continuation lines in the current buffer."
582 (nnheader-replace-regexp "\\(\r?\n[ \t]+\\)+" " ")) 597 (nnheader-replace-regexp "\\(\r?\n[ \t]+\\)+" " "))
583 598
584(defun nnheader-translate-file-chars (file) 599(defun nnheader-translate-file-chars (file &optional full)
600 "Translate FILE into something that can be a file name.
601If FULL, translate everything."
585 (if (null nnheader-file-name-translation-alist) 602 (if (null nnheader-file-name-translation-alist)
586 ;; No translation is necessary. 603 ;; No translation is necessary.
587 file 604 file
588 ;; We translate -- but only the file name. We leave the directory
589 ;; alone.
590 (let* ((i 0) 605 (let* ((i 0)
591 trans leaf path len) 606 trans leaf path len)
592 (if (string-match "/[^/]+\\'" file) 607 (if full
593 ;; This is needed on NT's and stuff. 608 ;; Do complete translation.
594 (setq leaf (substring file (1+ (match-beginning 0))) 609 (setq leaf (copy-sequence file)
595 path (substring file 0 (1+ (match-beginning 0)))) 610 path "")
596 ;; Fall back on this. 611 ;; We translate -- but only the file name. We leave the directory
597 (setq leaf (file-name-nondirectory file) 612 ;; alone.
598 path (file-name-directory file))) 613 (if (string-match "/[^/]+\\'" file)
614 ;; This is needed on NT's and stuff.
615 (setq leaf (substring file (1+ (match-beginning 0)))
616 path (substring file 0 (1+ (match-beginning 0))))
617 ;; Fall back on this.
618 (setq leaf (file-name-nondirectory file)
619 path (file-name-directory file))))
599 (setq len (length leaf)) 620 (setq len (length leaf))
600 (while (< i len) 621 (while (< i len)
601 (when (setq trans (cdr (assq (aref leaf i) 622 (when (setq trans (cdr (assq (aref leaf i)
@@ -616,9 +637,9 @@ The first string in ARGS can be a format string."
616(defun nnheader-get-report (backend) 637(defun nnheader-get-report (backend)
617 "Get the most recent report from BACKEND." 638 "Get the most recent report from BACKEND."
618 (condition-case () 639 (condition-case ()
619 (message "%s" (symbol-value (intern (format "%s-status-string" 640 (nnheader-message 5 "%s" (symbol-value (intern (format "%s-status-string"
620 backend)))) 641 backend))))
621 (error (message "")))) 642 (error (nnheader-message 5 ""))))
622 643
623(defun nnheader-insert (format &rest args) 644(defun nnheader-insert (format &rest args)
624 "Clear the communication buffer and insert FORMAT and ARGS into the buffer. 645 "Clear the communication buffer and insert FORMAT and ARGS into the buffer.
@@ -669,6 +690,9 @@ without formatting."
669 (or (not (numberp gnus-verbose-backends)) 690 (or (not (numberp gnus-verbose-backends))
670 (<= level gnus-verbose-backends))) 691 (<= level gnus-verbose-backends)))
671 692
693(defvar nnheader-pathname-coding-system 'iso-8859-1
694 "*Coding system for pathname.")
695
672;; 1997/8/10 by MORIOKA Tomohiko 696;; 1997/8/10 by MORIOKA Tomohiko
673(defvar nnheader-pathname-coding-system 697(defvar nnheader-pathname-coding-system
674 'iso-8859-1 698 'iso-8859-1
@@ -743,6 +767,9 @@ If FILE, find the \".../etc/PACKAGE\" file instead."
743 (when (string-match (car ange-ftp-path-format) path) 767 (when (string-match (car ange-ftp-path-format) path)
744 (ange-ftp-re-read-dir path))))) 768 (ange-ftp-re-read-dir path)))))
745 769
770(defvar nnheader-file-coding-system 'raw-text
771 "Coding system used in file backends of Gnus.")
772
746;; 1997/5/4 by MORIOKA Tomohiko <morioka@jaist.ac.jp> 773;; 1997/5/4 by MORIOKA Tomohiko <morioka@jaist.ac.jp>
747(defvar nnheader-file-coding-system nil 774(defvar nnheader-file-coding-system nil
748 "Coding system used in file backends of Gnus.") 775 "Coding system used in file backends of Gnus.")
@@ -756,8 +783,9 @@ find-file-hooks, etc.
756 (let ((format-alist nil) 783 (let ((format-alist nil)
757 (auto-mode-alist (nnheader-auto-mode-alist)) 784 (auto-mode-alist (nnheader-auto-mode-alist))
758 (default-major-mode 'fundamental-mode) 785 (default-major-mode 'fundamental-mode)
786 (enable-local-variables nil)
759 (after-insert-file-functions nil) 787 (after-insert-file-functions nil)
760 ;; 1997/5/4 by MORIOKA Tomohiko <morioka@jaist.ac.jp> 788 (find-file-hooks nil)
761 (coding-system-for-read nnheader-file-coding-system)) 789 (coding-system-for-read nnheader-file-coding-system))
762 (insert-file-contents filename visit beg end replace))) 790 (insert-file-contents filename visit beg end replace)))
763 791
@@ -767,7 +795,7 @@ find-file-hooks, etc.
767 (default-major-mode 'fundamental-mode) 795 (default-major-mode 'fundamental-mode)
768 (enable-local-variables nil) 796 (enable-local-variables nil)
769 (after-insert-file-functions nil) 797 (after-insert-file-functions nil)
770 ;; 1997/5/16 by MORIOKA Tomohiko <morioka@jaist.ac.jp> 798 (find-file-hooks nil)
771 (coding-system-for-read nnheader-file-coding-system)) 799 (coding-system-for-read nnheader-file-coding-system))
772 (apply 'find-file-noselect args))) 800 (apply 'find-file-noselect args)))
773 801
@@ -791,6 +819,16 @@ find-file-hooks, etc.
791 (pop files)) 819 (pop files))
792 (nreverse out))) 820 (nreverse out)))
793 821
822(defun nnheader-directory-files (&rest args)
823 "Same as `directory-files', but prune \".\" and \"..\"."
824 (let ((files (apply 'directory-files args))
825 out)
826 (while files
827 (unless (member (file-name-nondirectory (car files)) '("." ".."))
828 (push (car files) out))
829 (pop files))
830 (nreverse out)))
831
794(defmacro nnheader-skeleton-replace (from &optional to regexp) 832(defmacro nnheader-skeleton-replace (from &optional to regexp)
795 `(let ((new (generate-new-buffer " *nnheader replace*")) 833 `(let ((new (generate-new-buffer " *nnheader replace*"))
796 (cur (current-buffer)) 834 (cur (current-buffer))
diff --git a/lisp/gnus/nnkiboze.el b/lisp/gnus/nnkiboze.el
index 971d74a8f2e..c47a10d3911 100644
--- a/lisp/gnus/nnkiboze.el
+++ b/lisp/gnus/nnkiboze.el
@@ -1,7 +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 Free Software Foundation, Inc. 2;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: news 5;; Keywords: news
6 6
7;; This file is part of GNU Emacs. 7;; This file is part of GNU Emacs.
@@ -115,6 +115,8 @@
115 (save-excursion 115 (save-excursion
116 (set-buffer nntp-server-buffer) 116 (set-buffer nntp-server-buffer)
117 (erase-buffer) 117 (erase-buffer)
118 (unless (file-exists-p nov-file)
119 (nnkiboze-request-scan group))
118 (if (not (file-exists-p nov-file)) 120 (if (not (file-exists-p nov-file))
119 (nnheader-report 'nnkiboze "Can't select group %s" group) 121 (nnheader-report 'nnkiboze "Can't select group %s" group)
120 (nnheader-insert-file-contents nov-file) 122 (nnheader-insert-file-contents nov-file)
@@ -153,17 +155,17 @@
153(deffoo nnkiboze-request-delete-group (group &optional force server) 155(deffoo nnkiboze-request-delete-group (group &optional force server)
154 (nnkiboze-possibly-change-group group) 156 (nnkiboze-possibly-change-group group)
155 (when force 157 (when force
156 (let ((files (list (nnkiboze-nov-file-name) 158 (let ((files (nconc
157 (concat nnkiboze-directory 159 (nnkiboze-score-file group)
158 (nnheader-translate-file-chars 160 (list (nnkiboze-nov-file-name)
159 (concat group ".newsrc"))) 161 (nnkiboze-nov-file-name ".newsrc")))))
160 (nnkiboze-score-file group))))
161 (while files 162 (while files
162 (and (file-exists-p (car files)) 163 (and (file-exists-p (car files))
163 (file-writable-p (car files)) 164 (file-writable-p (car files))
164 (delete-file (car files))) 165 (delete-file (car files)))
165 (setq files (cdr files))))) 166 (setq files (cdr files)))))
166 (setq nnkiboze-current-group nil)) 167 (setq nnkiboze-current-group nil)
168 t)
167 169
168(nnoo-define-skeleton nnkiboze) 170(nnoo-define-skeleton nnkiboze)
169 171
@@ -178,7 +180,7 @@
178 180
179;;;###autoload 181;;;###autoload
180(defun nnkiboze-generate-groups () 182(defun nnkiboze-generate-groups ()
181 "Usage: emacs -batch -l nnkiboze -f nnkiboze-generate-groups 183 "\"Usage: emacs -batch -l nnkiboze -f nnkiboze-generate-groups\".
182Finds out what articles are to be part of the nnkiboze groups." 184Finds out what articles are to be part of the nnkiboze groups."
183 (interactive) 185 (interactive)
184 (let ((nnmail-spool-file nil) 186 (let ((nnmail-spool-file nil)
@@ -222,7 +224,7 @@ Finds out what articles are to be part of the nnkiboze groups."
222 (gnus-verbose (min gnus-verbose 3)) 224 (gnus-verbose (min gnus-verbose 3))
223 gnus-select-group-hook gnus-summary-prepare-hook 225 gnus-select-group-hook gnus-summary-prepare-hook
224 gnus-thread-sort-functions gnus-show-threads 226 gnus-thread-sort-functions gnus-show-threads
225 gnus-visual gnus-suppress-duplicates) 227 gnus-visual gnus-suppress-duplicates num-unread)
226 (unless info 228 (unless info
227 (error "No such group: %s" group)) 229 (error "No such group: %s" group))
228 ;; Load the kiboze newsrc file for this group. 230 ;; Load the kiboze newsrc file for this group.
@@ -265,7 +267,9 @@ Finds out what articles are to be part of the nnkiboze groups."
265 (gnus-group-jump-to-group (caar newsrc)) 267 (gnus-group-jump-to-group (caar newsrc))
266 (gnus-message 3 "nnkiboze: Checking %s..." (caar newsrc)) 268 (gnus-message 3 "nnkiboze: Checking %s..." (caar newsrc))
267 (setq ginfo (gnus-get-info (gnus-group-group-name)) 269 (setq ginfo (gnus-get-info (gnus-group-group-name))
268 orig-info (gnus-copy-sequence ginfo)) 270 orig-info (gnus-copy-sequence ginfo)
271 num-unread (car (gnus-gethash (caar newsrc)
272 gnus-newsrc-hashtb)))
269 (unwind-protect 273 (unwind-protect
270 (progn 274 (progn
271 ;; We set all list of article marks to nil. Since we operate 275 ;; We set all list of article marks to nil. Since we operate
@@ -283,7 +287,8 @@ Finds out what articles are to be part of the nnkiboze groups."
283 (car ginfo))) 287 (car ginfo)))
284 0)) 288 0))
285 (progn 289 (progn
286 (gnus-group-select-group nil) 290 (ignore-errors
291 (gnus-group-select-group nil))
287 (eq major-mode 'gnus-summary-mode))) 292 (eq major-mode 'gnus-summary-mode)))
288 ;; We are now in the group where we want to be. 293 ;; We are now in the group where we want to be.
289 (setq method (gnus-find-method-for-group 294 (setq method (gnus-find-method-for-group
@@ -302,10 +307,13 @@ Finds out what articles are to be part of the nnkiboze groups."
302 gnus-newsgroup-name)) 307 gnus-newsgroup-name))
303 (setq gnus-newsgroup-scored (cdr gnus-newsgroup-scored))) 308 (setq gnus-newsgroup-scored (cdr gnus-newsgroup-scored)))
304 ;; That's it. We exit this group. 309 ;; That's it. We exit this group.
305 (gnus-summary-exit-no-update))) 310 (when (eq major-mode 'gnus-summary-mode)
311 (kill-buffer (current-buffer)))))
306 ;; Restore the proper info. 312 ;; Restore the proper info.
307 (when ginfo 313 (when ginfo
308 (setcdr ginfo (cdr orig-info))))) 314 (setcdr ginfo (cdr orig-info)))
315 (setcar (gnus-gethash (caar newsrc) gnus-newsrc-hashtb)
316 num-unread)))
309 (setcdr (car newsrc) (car active)) 317 (setcdr (car newsrc) (car active))
310 (gnus-message 3 "nnkiboze: Checking %s...done" (caar newsrc)) 318 (gnus-message 3 "nnkiboze: Checking %s...done" (caar newsrc))
311 (setq newsrc (cdr newsrc)))) 319 (setq newsrc (cdr newsrc))))
@@ -313,17 +321,18 @@ Finds out what articles are to be part of the nnkiboze groups."
313 (nnheader-temp-write newsrc-file 321 (nnheader-temp-write newsrc-file
314 (insert "(setq nnkiboze-newsrc '") 322 (insert "(setq nnkiboze-newsrc '")
315 (gnus-prin1 nnkiboze-newsrc) 323 (gnus-prin1 nnkiboze-newsrc)
316 (insert ")\n")) 324 (insert ")\n")))
317 t)) 325 (save-excursion
326 (set-buffer gnus-group-buffer)
327 (gnus-group-list-groups))
328 t)
318 329
319(defun nnkiboze-enter-nov (buffer header group) 330(defun nnkiboze-enter-nov (buffer header group)
320 (save-excursion 331 (save-excursion
321 (set-buffer buffer) 332 (set-buffer buffer)
322 (goto-char (point-max)) 333 (goto-char (point-max))
323 (let ((xref (mail-header-xref header)) 334 (let ((prefix (gnus-group-real-prefix group))
324 (prefix (gnus-group-real-prefix group))
325 (oheader (copy-sequence header)) 335 (oheader (copy-sequence header))
326 (first t)
327 article) 336 article)
328 (if (zerop (forward-line -1)) 337 (if (zerop (forward-line -1))
329 (progn 338 (progn
@@ -339,16 +348,17 @@ Finds out what articles are to be part of the nnkiboze groups."
339 ;; The first Xref has to be the group this article 348 ;; The first Xref has to be the group this article
340 ;; really came for - this is the article nnkiboze 349 ;; really came for - this is the article nnkiboze
341 ;; will request when it is asked for the article. 350 ;; will request when it is asked for the article.
342 (insert group ":" 351 (insert " " group ":"
343 (int-to-string (mail-header-number header)) " ") 352 (int-to-string (mail-header-number header)) " ")
344 (while (re-search-forward " [^ ]+:[0-9]+" nil t) 353 (while (re-search-forward " [^ ]+:[0-9]+" nil t)
345 (goto-char (1+ (match-beginning 0))) 354 (goto-char (1+ (match-beginning 0)))
346 (insert prefix))))) 355 (insert prefix)))))
347 356
348(defun nnkiboze-nov-file-name () 357(defun nnkiboze-nov-file-name (&optional suffix)
349 (concat (file-name-as-directory nnkiboze-directory) 358 (concat (file-name-as-directory nnkiboze-directory)
350 (nnheader-translate-file-chars 359 (nnheader-translate-file-chars
351 (concat (nnkiboze-prefixed-name nnkiboze-current-group) ".nov")))) 360 (concat (nnkiboze-prefixed-name nnkiboze-current-group)
361 (or suffix ".nov")))))
352 362
353(provide 'nnkiboze) 363(provide 'nnkiboze)
354 364
diff --git a/lisp/gnus/nnmail.el b/lisp/gnus/nnmail.el
index a3ed26c45c0..056600b8255 100644
--- a/lisp/gnus/nnmail.el
+++ b/lisp/gnus/nnmail.el
@@ -1,7 +1,7 @@
1;;; nnmail.el --- mail support functions for the Gnus mail backends 1;;; nnmail.el --- mail support functions for the Gnus mail backends
2;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. 2;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: news, mail 5;; Keywords: news, mail
6 6
7;; This file is part of GNU Emacs. 7;; This file is part of GNU Emacs.
@@ -31,9 +31,12 @@
31(require 'timezone) 31(require 'timezone)
32(require 'message) 32(require 'message)
33(require 'custom) 33(require 'custom)
34(require 'gnus-util)
34 35
35(eval-and-compile 36(eval-and-compile
36 (autoload 'gnus-error "gnus-util")) 37 (autoload 'gnus-error "gnus-util")
38 (autoload 'gnus-buffer-live-p "gnus-util")
39 (autoload 'gnus-encode-coding-string "gnus-ems"))
37 40
38(defgroup nnmail nil 41(defgroup nnmail nil
39 "Reading mail with Gnus." 42 "Reading mail with Gnus."
@@ -74,7 +77,7 @@
74 77
75(defcustom nnmail-split-methods 78(defcustom nnmail-split-methods
76 '(("mail.misc" "")) 79 '(("mail.misc" ""))
77 "Incoming mail will be split according to this variable. 80 "*Incoming mail will be split according to this variable.
78 81
79If you'd like, for instance, one mail group for mail from the 82If you'd like, for instance, one mail group for mail from the
80\"4ad-l\" mailing list, one group for junk mail and one for everything 83\"4ad-l\" mailing list, one group for junk mail and one for everything
@@ -171,7 +174,7 @@ Eg.:
171(defcustom nnmail-spool-file 174(defcustom nnmail-spool-file
172 (or (getenv "MAIL") 175 (or (getenv "MAIL")
173 (concat "/usr/spool/mail/" (user-login-name))) 176 (concat "/usr/spool/mail/" (user-login-name)))
174 "Where the mail backends will look for incoming mail. 177 "*Where the mail backends will look for incoming mail.
175This variable is \"/usr/spool/mail/$user\" by default. 178This variable is \"/usr/spool/mail/$user\" by default.
176If this variable is nil, no mail backends will read incoming mail. 179If this variable is nil, no mail backends will read incoming mail.
177If this variable is a list, all files mentioned in this list will be 180If this variable is a list, all files mentioned in this list will be
@@ -179,7 +182,8 @@ used as incoming mailboxes.
179If this variable is a directory (i. e., it's name ends with a \"/\"), 182If this variable is a directory (i. e., it's name ends with a \"/\"),
180treat all files in that directory as incoming spool files." 183treat all files in that directory as incoming spool files."
181 :group 'nnmail-files 184 :group 'nnmail-files
182 :type 'file) 185 :type '(choice (file :tag "File")
186 (repeat :tag "Files" file)))
183 187
184(defcustom nnmail-crash-box "~/.gnus-crash-box" 188(defcustom nnmail-crash-box "~/.gnus-crash-box"
185 "File where Gnus will store mail while processing it." 189 "File where Gnus will store mail while processing it."
@@ -216,10 +220,10 @@ several files - eg. \".spool[0-9]*\"."
216 :type 'function) 220 :type 'function)
217 221
218(defcustom nnmail-crosspost-link-function 222(defcustom nnmail-crosspost-link-function
219 (if (string-match "windows-nt\\|emx" (format "%s" system-type)) 223 (if (string-match "windows-nt\\|emx" (symbol-name system-type))
220 'copy-file 224 'copy-file
221 'add-name-to-file) 225 'add-name-to-file)
222 "Function called to create a copy of a file. 226 "*Function called to create a copy of a file.
223This is `add-name-to-file' by default, which means that crossposts 227This is `add-name-to-file' by default, which means that crossposts
224will use hard links. If your file system doesn't allow hard 228will use hard links. If your file system doesn't allow hard
225links, you could set this variable to `copy-file' instead." 229links, you could set this variable to `copy-file' instead."
@@ -248,7 +252,7 @@ to be moved to."
248 (if (eq system-type 'windows-nt) 252 (if (eq system-type 'windows-nt)
249 '(nnheader-ms-strip-cr) 253 '(nnheader-ms-strip-cr)
250 nil) 254 nil)
251 "Hook that will be run after the incoming mail has been transferred. 255 "*Hook that will be run after the incoming mail has been transferred.
252The incoming mail is moved from `nnmail-spool-file' (which normally is 256The incoming mail is moved from `nnmail-spool-file' (which normally is
253something like \"/usr/spool/mail/$user\") to the user's home 257something like \"/usr/spool/mail/$user\") to the user's home
254directory. This hook is called after the incoming mail box has been 258directory. This hook is called after the incoming mail box has been
@@ -300,8 +304,8 @@ that) from the headers before splitting and saving the messages."
300This can also be a list of regexps." 304This can also be a list of regexps."
301 :group 'nnmail-prepare 305 :group 'nnmail-prepare
302 :type '(choice (const :tag "none" nil) 306 :type '(choice (const :tag "none" nil)
303 regexp 307 (regexp :value ".*")
304 (repeat regexp))) 308 (repeat :value (".*") regexp)))
305 309
306(defcustom nnmail-pre-get-new-mail-hook nil 310(defcustom nnmail-pre-get-new-mail-hook nil
307 "Hook called just before starting to handle new incoming mail." 311 "Hook called just before starting to handle new incoming mail."
@@ -341,7 +345,7 @@ messages will be shown to indicate the current status."
341 "Incoming mail can be split according to this fancy variable. 345 "Incoming mail can be split according to this fancy variable.
342To enable this, set `nnmail-split-methods' to `nnmail-split-fancy'. 346To enable this, set `nnmail-split-methods' to `nnmail-split-fancy'.
343 347
344The format is this variable is SPLIT, where SPLIT can be one of 348The format of this variable is SPLIT, where SPLIT can be one of
345the following: 349the following:
346 350
347GROUP: Mail will be stored in GROUP (a string). 351GROUP: Mail will be stored in GROUP (a string).
@@ -401,7 +405,7 @@ Example:
401 (from . "from\\|sender\\|resent-from") 405 (from . "from\\|sender\\|resent-from")
402 (nato . "to\\|cc\\|resent-to\\|resent-cc") 406 (nato . "to\\|cc\\|resent-to\\|resent-cc")
403 (naany . "from\\|to\\|cc\\|sender\\|resent-from\\|resent-to\\|resent-cc")) 407 (naany . "from\\|to\\|cc\\|sender\\|resent-from\\|resent-to\\|resent-cc"))
404 "Alist of abbreviations allowed in `nnmail-split-fancy'." 408 "*Alist of abbreviations allowed in `nnmail-split-fancy'."
405 :group 'nnmail-split 409 :group 'nnmail-split
406 :type '(repeat (cons :format "%v" symbol regexp))) 410 :type '(repeat (cons :format "%v" symbol regexp)))
407 411
@@ -445,6 +449,8 @@ parameter. It should return nil, `warn' or `delete'."
445(defvar nnmail-split-history nil 449(defvar nnmail-split-history nil
446 "List of group/article elements that say where the previous split put messages.") 450 "List of group/article elements that say where the previous split put messages.")
447 451
452(defvar nnmail-current-spool nil)
453
448(defvar nnmail-pop-password nil 454(defvar nnmail-pop-password nil
449 "*Password to use when reading mail from a POP server, if required.") 455 "*Password to use when reading mail from a POP server, if required.")
450 456
@@ -464,6 +470,9 @@ parameter. It should return nil, `warn' or `delete'."
464 470
465(defvar nnmail-internal-password nil) 471(defvar nnmail-internal-password nil)
466 472
473(defvar nnmail-split-tracing nil)
474(defvar nnmail-split-trace nil)
475
467 476
468 477
469(defconst nnmail-version "nnmail 1.0" 478(defconst nnmail-version "nnmail 1.0"
@@ -474,7 +483,9 @@ parameter. It should return nil, `warn' or `delete'."
474(defun nnmail-request-post (&optional server) 483(defun nnmail-request-post (&optional server)
475 (mail-send-and-exit nil)) 484 (mail-send-and-exit nil))
476 485
477;; 1997/5/4 by MORIOKA Tomohiko <morioka@jaist.ac.jp> 486(defvar nnmail-file-coding-system 'raw-text
487 "Coding system used in nnmail.")
488
478(defvar nnmail-file-coding-system nil 489(defvar nnmail-file-coding-system nil
479 "Coding system used in nnmail.") 490 "Coding system used in nnmail.")
480 491
@@ -485,16 +496,13 @@ parameter. It should return nil, `warn' or `delete'."
485 (let ((format-alist nil) 496 (let ((format-alist nil)
486 (after-insert-file-functions nil)) 497 (after-insert-file-functions nil))
487 (condition-case () 498 (condition-case ()
488 ;; 1997/5/4 by MORIOKA Tomohiko <morioka@jaist.ac.jp>
489 (let ((coding-system-for-read nnmail-file-coding-system) 499 (let ((coding-system-for-read nnmail-file-coding-system)
490 ;; 1997/8/12 by MORIOKA Tomohiko 500 (file-name-coding-system 'binary)
491 (file-name-coding-system 'binary) ; for Emacs 20 501 (pathname-coding-system 'binary))
492 (pathname-coding-system 'binary)) ; for XEmacs/mule
493 (insert-file-contents file) 502 (insert-file-contents file)
494 t) 503 t)
495 (file-error nil)))) 504 (file-error nil))))
496 505
497;; 1997/8/10 by MORIOKA Tomohiko
498(defvar nnmail-pathname-coding-system 506(defvar nnmail-pathname-coding-system
499 'iso-8859-1 507 'iso-8859-1
500 "*Coding system for pathname.") 508 "*Coding system for pathname.")
@@ -503,6 +511,7 @@ parameter. It should return nil, `warn' or `delete'."
503 "Make pathname for GROUP." 511 "Make pathname for GROUP."
504 (concat 512 (concat
505 (let ((dir (file-name-as-directory (expand-file-name dir)))) 513 (let ((dir (file-name-as-directory (expand-file-name dir))))
514 (setq group (nnheader-translate-file-chars group))
506 ;; If this directory exists, we use it directly. 515 ;; If this directory exists, we use it directly.
507 (if (or nnmail-use-long-file-names 516 (if (or nnmail-use-long-file-names
508 (file-directory-p (concat dir group))) 517 (file-directory-p (concat dir group)))
@@ -527,7 +536,8 @@ parameter. It should return nil, `warn' or `delete'."
527 (aref t1 2) (aref t1 1) (aref t1 0) 536 (aref t1 2) (aref t1 1) (aref t1 0)
528 (aref d1 2) (aref d1 1) (aref d1 0) 537 (aref d1 2) (aref d1 1) (aref d1 0)
529 (number-to-string 538 (number-to-string
530 (* 60 (timezone-zone-to-minute (aref d1 4)))))))) 539 (* 60 (timezone-zone-to-minute
540 (or (aref d1 4) (current-time-zone)))))))))
531 ;; If we get an error, then we just return a 0 time. 541 ;; If we get an error, then we just return a 0 time.
532 (error (list 0 0)))) 542 (error (list 0 0))))
533 543
@@ -541,7 +551,7 @@ parameter. It should return nil, `warn' or `delete'."
541 "Convert DAYS into time." 551 "Convert DAYS into time."
542 (let* ((seconds (* 1.0 days 60 60 24)) 552 (let* ((seconds (* 1.0 days 60 60 24))
543 (rest (expt 2 16)) 553 (rest (expt 2 16))
544 (ms (condition-case nil (round (/ seconds rest)) 554 (ms (condition-case nil (floor (/ seconds rest))
545 (range-error (expt 2 16))))) 555 (range-error (expt 2 16)))))
546 (list ms (condition-case nil (round (- seconds (* ms rest))) 556 (list ms (condition-case nil (round (- seconds (* ms rest)))
547 (range-error (expt 2 16)))))) 557 (range-error (expt 2 16))))))
@@ -591,12 +601,12 @@ parameter. It should return nil, `warn' or `delete'."
591 (nnmail-read-passwd 601 (nnmail-read-passwd
592 (format "Password for %s: " 602 (format "Password for %s: "
593 (substring inbox (+ popmail 3)))))) 603 (substring inbox (+ popmail 3))))))
594 (message "Getting mail from the post office...")) 604 (nnheader-message 5 "Getting mail from the post office..."))
595 (when (or (and (file-exists-p tofile) 605 (when (or (and (file-exists-p tofile)
596 (/= 0 (nnheader-file-size tofile))) 606 (/= 0 (nnheader-file-size tofile)))
597 (and (file-exists-p inbox) 607 (and (file-exists-p inbox)
598 (/= 0 (nnheader-file-size inbox)))) 608 (/= 0 (nnheader-file-size inbox))))
599 (message "Getting mail from %s..." inbox))) 609 (nnheader-message 5 "Getting mail from %s..." inbox)))
600 ;; Set TOFILE if have not already done so, and 610 ;; Set TOFILE if have not already done so, and
601 ;; rename or copy the file INBOX to TOFILE if and as appropriate. 611 ;; rename or copy the file INBOX to TOFILE if and as appropriate.
602 (cond 612 (cond
@@ -615,17 +625,17 @@ parameter. It should return nil, `warn' or `delete'."
615 (save-excursion 625 (save-excursion
616 (setq errors (generate-new-buffer " *nnmail loss*")) 626 (setq errors (generate-new-buffer " *nnmail loss*"))
617 (buffer-disable-undo errors) 627 (buffer-disable-undo errors)
618 (let ((default-directory "/")) 628 (if (nnheader-functionp nnmail-movemail-program)
619 (if (nnheader-functionp nnmail-movemail-program) 629 (condition-case err
620 (condition-case err 630 (progn
621 (progn 631 (funcall nnmail-movemail-program inbox tofile)
622 (funcall nnmail-movemail-program inbox tofile) 632 (setq result 0))
623 (setq result 0)) 633 (error
624 (error 634 (save-excursion
625 (save-excursion 635 (set-buffer errors)
626 (set-buffer errors) 636 (insert (prin1-to-string err))
627 (insert (prin1-to-string err)) 637 (setq result 255))))
628 (setq result 255)))) 638 (let ((default-directory "/"))
629 (setq result 639 (setq result
630 (apply 640 (apply
631 'call-process 641 'call-process
@@ -636,14 +646,14 @@ parameter. It should return nil, `warn' or `delete'."
636 nil errors nil inbox tofile) 646 nil errors nil inbox tofile)
637 (when nnmail-internal-password 647 (when nnmail-internal-password
638 (list nnmail-internal-password))))))) 648 (list nnmail-internal-password)))))))
649 (push inbox nnmail-moved-inboxes)
639 (if (and (not (buffer-modified-p errors)) 650 (if (and (not (buffer-modified-p errors))
640 (zerop result)) 651 (zerop result))
641 ;; No output => movemail won 652 ;; No output => movemail won
642 (progn 653 (progn
643 (unless popmail 654 (unless popmail
644 (when (file-exists-p tofile) 655 (when (file-exists-p tofile)
645 (set-file-modes tofile nnmail-default-file-modes))) 656 (set-file-modes tofile nnmail-default-file-modes))))
646 (push inbox nnmail-moved-inboxes))
647 (set-buffer errors) 657 (set-buffer errors)
648 ;; There may be a warning about older revisions. We 658 ;; There may be a warning about older revisions. We
649 ;; ignore those. 659 ;; ignore those.
@@ -652,9 +662,12 @@ parameter. It should return nil, `warn' or `delete'."
652 (progn 662 (progn
653 (unless popmail 663 (unless popmail
654 (when (file-exists-p tofile) 664 (when (file-exists-p tofile)
655 (set-file-modes tofile nnmail-default-file-modes))) 665 (set-file-modes
656 (push inbox nnmail-moved-inboxes)) 666 tofile nnmail-default-file-modes))))
657 ;; Probably a real error. 667 ;; Probably a real error.
668 ;; We nix out the password in case the error
669 ;; was because of a wrong password being given.
670 (setq nnmail-internal-password nil)
658 (subst-char-in-region (point-min) (point-max) ?\n ?\ ) 671 (subst-char-in-region (point-min) (point-max) ?\n ?\ )
659 (goto-char (point-max)) 672 (goto-char (point-max))
660 (skip-chars-backward " \t") 673 (skip-chars-backward " \t")
@@ -667,7 +680,7 @@ parameter. It should return nil, `warn' or `delete'."
667 (buffer-string) result)) 680 (buffer-string) result))
668 (error "%s" (buffer-string))) 681 (error "%s" (buffer-string)))
669 (setq tofile nil))))))) 682 (setq tofile nil)))))))
670 (message "Getting mail from %s...done" inbox) 683 (nnheader-message 5 "Getting mail from %s...done" inbox)
671 (and errors 684 (and errors
672 (buffer-name errors) 685 (buffer-name errors)
673 (kill-buffer errors)) 686 (kill-buffer errors))
@@ -690,9 +703,7 @@ nn*-request-list should have been called before calling this function."
690 group-assoc))) 703 group-assoc)))
691 group-assoc)) 704 group-assoc))
692 705
693;; 1997/8/12 by MORIOKA Tomohiko 706(defvar nnmail-active-file-coding-system 'binary
694(defvar nnmail-active-file-coding-system
695 'iso-8859-1
696 "*Coding system for active file.") 707 "*Coding system for active file.")
697 708
698(defun nnmail-save-active (group-assoc file-name) 709(defun nnmail-save-active (group-assoc file-name)
@@ -718,10 +729,12 @@ return nil if FILE is a spool file or the procmail group for which it
718is a spool. If not using procmail, return GROUP." 729is a spool. If not using procmail, return GROUP."
719 (if (or (eq nnmail-spool-file 'procmail) 730 (if (or (eq nnmail-spool-file 'procmail)
720 nnmail-use-procmail) 731 nnmail-use-procmail)
721 (if (string-match (concat "^" (expand-file-name 732 (if (string-match (concat "^" (regexp-quote
722 (file-name-as-directory 733 (expand-file-name
723 nnmail-procmail-directory)) 734 (file-name-as-directory
724 "\\([^/]*\\)" nnmail-procmail-suffix "$") 735 nnmail-procmail-directory)))
736 "\\([^/]*\\)"
737 nnmail-procmail-suffix "$")
725 (expand-file-name file)) 738 (expand-file-name file))
726 (let ((procmail-group (substring (expand-file-name file) 739 (let ((procmail-group (substring (expand-file-name file)
727 (match-beginning 1) 740 (match-beginning 1)
@@ -737,8 +750,8 @@ is a spool. If not using procmail, return GROUP."
737(defun nnmail-process-babyl-mail-format (func artnum-func) 750(defun nnmail-process-babyl-mail-format (func artnum-func)
738 (let ((case-fold-search t) 751 (let ((case-fold-search t)
739 start message-id content-length do-search end) 752 start message-id content-length do-search end)
740 (goto-char (point-min))
741 (while (not (eobp)) 753 (while (not (eobp))
754 (goto-char (point-min))
742 (re-search-forward 755 (re-search-forward
743 " \n0, *unseen,+\n\\(\\*\\*\\* EOOH \\*\\*\\*\n\\)?" nil t) 756 " \n0, *unseen,+\n\\(\\*\\*\\* EOOH \\*\\*\\*\n\\)?" nil t)
744 (goto-char (match-end 0)) 757 (goto-char (match-end 0))
@@ -875,7 +888,9 @@ is a spool. If not using procmail, return GROUP."
875 (if (not (and (re-search-forward "^From " nil t) 888 (if (not (and (re-search-forward "^From " nil t)
876 (goto-char (match-beginning 0)))) 889 (goto-char (match-beginning 0))))
877 ;; Possibly wrong format? 890 ;; Possibly wrong format?
878 (error "Error, unknown mail format! (Possibly corrupted.)") 891 (progn
892 (pop-to-buffer (nnheader-find-file-noselect nnmail-current-spool))
893 (error "Error, unknown mail format! (Possibly corrupted.)"))
879 ;; Carry on until the bitter end. 894 ;; Carry on until the bitter end.
880 (while (not (eobp)) 895 (while (not (eobp))
881 (setq start (point) 896 (setq start (point)
@@ -960,7 +975,9 @@ is a spool. If not using procmail, return GROUP."
960 (if (not (and (re-search-forward delim nil t) 975 (if (not (and (re-search-forward delim nil t)
961 (forward-line 1))) 976 (forward-line 1)))
962 ;; Possibly wrong format? 977 ;; Possibly wrong format?
963 (error "Error, unknown mail format! (Possibly corrupted.)") 978 (progn
979 (pop-to-buffer (nnheader-find-file-noselect nnmail-current-spool))
980 (error "Error, unknown mail format! (Possibly corrupted.)"))
964 ;; Carry on until the bitter end. 981 ;; Carry on until the bitter end.
965 (while (not (eobp)) 982 (while (not (eobp))
966 (setq start (point)) 983 (setq start (point))
@@ -1038,15 +1055,15 @@ FUNC will be called with the buffer narrowed to each mail."
1038 (funcall exit-func)) 1055 (funcall exit-func))
1039 (kill-buffer (current-buffer))))) 1056 (kill-buffer (current-buffer)))))
1040 1057
1041;; Mail crossposts suggested by Brian Edmonds <edmonds@cs.ubc.ca>. 1058(defun nnmail-article-group (func &optional trace)
1042(defun nnmail-article-group (func)
1043 "Look at the headers and return an alist of groups that match. 1059 "Look at the headers and return an alist of groups that match.
1044FUNC will be called with the group name to determine the article number." 1060FUNC will be called with the group name to determine the article number."
1045 (let ((methods nnmail-split-methods) 1061 (let ((methods nnmail-split-methods)
1046 (obuf (current-buffer)) 1062 (obuf (current-buffer))
1047 (beg (point-min)) 1063 (beg (point-min))
1048 end group-art method) 1064 end group-art method regrepp)
1049 (if (and (sequencep methods) (= (length methods) 1)) 1065 (if (and (sequencep methods)
1066 (= (length methods) 1))
1050 ;; If there is only just one group to put everything in, we 1067 ;; If there is only just one group to put everything in, we
1051 ;; just return a list with just this one method in. 1068 ;; just return a list with just this one method in.
1052 (setq group-art 1069 (setq group-art
@@ -1064,8 +1081,21 @@ FUNC will be called with the group name to determine the article number."
1064 (goto-char (point-min)) 1081 (goto-char (point-min))
1065 (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t) 1082 (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
1066 (replace-match " " t t)) 1083 (replace-match " " t t))
1084 ;; Nuke pathologically long headers. Since Gnus applies
1085 ;; pathologically complex regexps to the buffer, lines
1086 ;; that are looong will take longer than the Universe's
1087 ;; existence to process.
1088 (goto-char (point-min))
1089 (while (not (eobp))
1090 (end-of-line)
1091 (if (> (current-column) 1024)
1092 (gnus-delete-line)
1093 (forward-line 1)))
1067 ;; Allow washing. 1094 ;; Allow washing.
1095 (goto-char (point-min))
1068 (run-hooks 'nnmail-split-hook) 1096 (run-hooks 'nnmail-split-hook)
1097 (when (setq nnmail-split-tracing trace)
1098 (setq nnmail-split-trace nil))
1069 (if (and (symbolp nnmail-split-methods) 1099 (if (and (symbolp nnmail-split-methods)
1070 (fboundp nnmail-split-methods)) 1100 (fboundp nnmail-split-methods))
1071 (let ((split 1101 (let ((split
@@ -1076,10 +1106,11 @@ FUNC will be called with the group name to determine the article number."
1076 (or (funcall nnmail-split-methods) 1106 (or (funcall nnmail-split-methods)
1077 '("bogus")) 1107 '("bogus"))
1078 (error 1108 (error
1079 (message 1109 (nnheader-message 5
1080 "Error in `nnmail-split-methods'; using `bogus' mail group") 1110 "Error in `nnmail-split-methods'; using `bogus' mail group")
1081 (sit-for 1) 1111 (sit-for 1)
1082 '("bogus"))))) 1112 '("bogus")))))
1113 (setq split (gnus-remove-duplicates split))
1083 ;; The article may be "cross-posted" to `junk'. What 1114 ;; The article may be "cross-posted" to `junk'. What
1084 ;; to do? Just remove the `junk' spec. Don't really 1115 ;; to do? Just remove the `junk' spec. Don't really
1085 ;; see anything else to do... 1116 ;; see anything else to do...
@@ -1092,21 +1123,30 @@ FUNC will be called with the group name to determine the article number."
1092 (lambda (group) (cons group (funcall func group))) 1123 (lambda (group) (cons group (funcall func group)))
1093 split)))) 1124 split))))
1094 ;; Go through the split methods to find a match. 1125 ;; Go through the split methods to find a match.
1095 (while (and methods (or nnmail-crosspost (not group-art))) 1126 (while (and methods
1127 (or nnmail-crosspost
1128 (not group-art)))
1096 (goto-char (point-max)) 1129 (goto-char (point-max))
1097 (setq method (pop methods)) 1130 (setq method (pop methods)
1131 regrepp nil)
1098 (if (or methods 1132 (if (or methods
1099 (not (equal "" (nth 1 method)))) 1133 (not (equal "" (nth 1 method))))
1100 (when (and 1134 (when (and
1101 (ignore-errors 1135 (ignore-errors
1102 (if (stringp (nth 1 method)) 1136 (if (stringp (nth 1 method))
1103 (re-search-backward (cadr method) nil t) 1137 (progn
1138 (setq regrepp
1139 (string-match "\\\\[0-9&]" (car method)))
1140 (re-search-backward (cadr method) nil t))
1104 ;; Function to say whether this is a match. 1141 ;; Function to say whether this is a match.
1105 (funcall (nth 1 method) (car method)))) 1142 (funcall (nth 1 method) (car method))))
1106 ;; Don't enter the article into the same 1143 ;; Don't enter the article into the same
1107 ;; group twice. 1144 ;; group twice.
1108 (not (assoc (car method) group-art))) 1145 (not (assoc (car method) group-art)))
1109 (push (cons (car method) (funcall func (car method))) 1146 (push (cons (if regrepp
1147 (nnmail-expand-newtext (car method))
1148 (car method))
1149 (funcall func (car method)))
1110 group-art)) 1150 group-art))
1111 ;; This is the final group, which is used as a 1151 ;; This is the final group, which is used as a
1112 ;; catch-all. 1152 ;; catch-all.
@@ -1114,6 +1154,18 @@ FUNC will be called with the group name to determine the article number."
1114 (setq group-art 1154 (setq group-art
1115 (list (cons (car method) 1155 (list (cons (car method)
1116 (funcall func (car method))))))))) 1156 (funcall func (car method)))))))))
1157 ;; Produce a trace if non-empty.
1158 (when (and trace nnmail-split-trace)
1159 (let ((trace (nreverse nnmail-split-trace))
1160 (restore (current-buffer)))
1161 (nnheader-set-temp-buffer "*Split Trace*")
1162 (gnus-add-buffer)
1163 (while trace
1164 (insert (car trace) "\n")
1165 (setq trace (cdr trace)))
1166 (goto-char (point-min))
1167 (gnus-configure-windows 'split-trace)
1168 (set-buffer restore)))
1117 ;; See whether the split methods returned `junk'. 1169 ;; See whether the split methods returned `junk'.
1118 (if (equal group-art '(junk)) 1170 (if (equal group-art '(junk))
1119 nil 1171 nil
@@ -1154,8 +1206,9 @@ Return the number of characters in the body."
1154 (insert (format "Xref: %s" (system-name))) 1206 (insert (format "Xref: %s" (system-name)))
1155 (while group-alist 1207 (while group-alist
1156 (insert (format " %s:%d" 1208 (insert (format " %s:%d"
1157 (gnus-encode-coding-string (caar group-alist) 1209 (gnus-encode-coding-string
1158 nnmail-pathname-coding-system) 1210 (caar group-alist)
1211 nnmail-pathname-coding-system)
1159 (cdar group-alist))) 1212 (cdar group-alist)))
1160 (setq group-alist (cdr group-alist))) 1213 (setq group-alist (cdr group-alist)))
1161 (insert "\n")))) 1214 (insert "\n"))))
@@ -1185,7 +1238,6 @@ Return the number of characters in the body."
1185 1238
1186;;; Utility functions 1239;;; Utility functions
1187 1240
1188;; Written by byer@mv.us.adobe.com (Scott Byer).
1189(defun nnmail-make-complex-temp-name (prefix) 1241(defun nnmail-make-complex-temp-name (prefix)
1190 (let ((newname (make-temp-name prefix)) 1242 (let ((newname (make-temp-name prefix))
1191 (newprefix prefix)) 1243 (newprefix prefix))
@@ -1211,81 +1263,87 @@ See the documentation for the variable `nnmail-split-fancy' for documentation."
1211 1263
1212(defun nnmail-split-it (split) 1264(defun nnmail-split-it (split)
1213 ;; Return a list of groups matching SPLIT. 1265 ;; Return a list of groups matching SPLIT.
1214 (cond 1266 (let (cached-pair)
1215 ;; nil split 1267 (cond
1216 ((null split) 1268 ;; nil split
1217 nil) 1269 ((null split)
1218 1270 nil)
1219 ;; A group name. Do the \& and \N subs into the string. 1271
1220 ((stringp split) 1272 ;; A group name. Do the \& and \N subs into the string.
1221 (list (nnmail-expand-newtext split))) 1273 ((stringp split)
1222 1274 (when nnmail-split-tracing
1223 ;; Junk the message. 1275 (push (format "\"%s\"" split) nnmail-split-trace))
1224 ((eq split 'junk) 1276 (list (nnmail-expand-newtext split)))
1225 (list 'junk)) 1277
1226 1278 ;; Junk the message.
1227 ;; Builtin & operation. 1279 ((eq split 'junk)
1228 ((eq (car split) '&) 1280 (when nnmail-split-tracing
1229 (apply 'nconc (mapcar 'nnmail-split-it (cdr split)))) 1281 (push "junk" nnmail-split-trace))
1230 1282 (list 'junk))
1231 ;; Builtin | operation. 1283
1232 ((eq (car split) '|) 1284 ;; Builtin & operation.
1233 (let (done) 1285 ((eq (car split) '&)
1234 (while (and (not done) (cdr split)) 1286 (apply 'nconc (mapcar 'nnmail-split-it (cdr split))))
1235 (setq split (cdr split) 1287
1236 done (nnmail-split-it (car split)))) 1288 ;; Builtin | operation.
1237 done)) 1289 ((eq (car split) '|)
1238 1290 (let (done)
1239 ;; Builtin : operation. 1291 (while (and (not done) (cdr split))
1240 ((eq (car split) ':) 1292 (setq split (cdr split)
1241 (nnmail-split-it (eval (cdr split)))) 1293 done (nnmail-split-it (car split))))
1242 1294 done))
1243 ;; Check the cache for the regexp for this split. 1295
1244 ;; FIX FIX FIX could avoid calling assq twice here 1296 ;; Builtin : operation.
1245 ((assq split nnmail-split-cache) 1297 ((eq (car split) ':)
1246 (goto-char (point-max)) 1298 (nnmail-split-it (save-excursion (eval (cdr split)))))
1247 ;; FIX FIX FIX problem with re-search-backward is that if you have 1299
1248 ;; a split: (from "foo-\\(bar\\|baz\\)@gnus.org "mail.foo.\\1") 1300 ;; Check the cache for the regexp for this split.
1249 ;; and someone mails a message with 'To: foo-bar@gnus.org' and 1301 ((setq cached-pair (assq split nnmail-split-cache))
1250 ;; 'CC: foo-baz@gnus.org', we'll pick 'mail.foo.baz' as the group 1302 (goto-char (point-max))
1251 ;; if the cc line is a later header, even though the other choice 1303 ;; FIX FIX FIX problem with re-search-backward is that if you have
1252 ;; is probably better. Also, this routine won't do a crosspost 1304 ;; a split: (from "foo-\\(bar\\|baz\\)@gnus.org "mail.foo.\\1")
1253 ;; when there are two different matches. 1305 ;; and someone mails a message with 'To: foo-bar@gnus.org' and
1254 ;; I guess you could just make this more determined, and it could 1306 ;; 'CC: foo-baz@gnus.org', we'll pick 'mail.foo.baz' as the group
1255 ;; look for still more matches prior to this one, and recurse 1307 ;; if the cc line is a later header, even though the other choice
1256 ;; on each of the multiple matches hit. Of course, then you'd 1308 ;; is probably better. Also, this routine won't do a crosspost
1257 ;; want to make sure that nnmail-article-group or nnmail-split-fancy 1309 ;; when there are two different matches.
1258 ;; removed duplicates, since there might be more of those. 1310 ;; I guess you could just make this more determined, and it could
1259 ;; I guess we could also remove duplicates in the & split case, since 1311 ;; look for still more matches prior to this one, and recurse
1260 ;; that's the only thing that can introduce them. 1312 ;; on each of the multiple matches hit. Of course, then you'd
1261 (when (re-search-backward (cdr (assq split nnmail-split-cache)) nil t) 1313 ;; want to make sure that nnmail-article-group or nnmail-split-fancy
1262 ;; Someone might want to do a \N sub on this match, so get the 1314 ;; removed duplicates, since there might be more of those.
1263 ;; correct match positions. 1315 ;; I guess we could also remove duplicates in the & split case, since
1264 (goto-char (match-end 0)) 1316 ;; that's the only thing that can introduce them.
1265 (let ((value (nth 1 split))) 1317 (when (re-search-backward (cdr cached-pair) nil t)
1266 (re-search-backward (if (symbolp value) 1318 (when nnmail-split-tracing
1267 (cdr (assq value nnmail-split-abbrev-alist)) 1319 (push (cdr cached-pair) nnmail-split-trace))
1268 value) 1320 ;; Someone might want to do a \N sub on this match, so get the
1269 (match-end 1))) 1321 ;; correct match positions.
1270 (nnmail-split-it (nth 2 split)))) 1322 (goto-char (match-end 0))
1271 1323 (let ((value (nth 1 split)))
1272 ;; Not in cache, compute a regexp for the field/value pair. 1324 (re-search-backward (if (symbolp value)
1273 (t 1325 (cdr (assq value nnmail-split-abbrev-alist))
1274 (let* ((field (nth 0 split)) 1326 value)
1275 (value (nth 1 split)) 1327 (match-end 1)))
1276 (regexp (concat "^\\(\\(" 1328 (nnmail-split-it (nth 2 split))))
1277 (if (symbolp field) 1329
1278 (cdr (assq field nnmail-split-abbrev-alist)) 1330 ;; Not in cache, compute a regexp for the field/value pair.
1279 field) 1331 (t
1280 "\\):.*\\)\\<\\(" 1332 (let* ((field (nth 0 split))
1281 (if (symbolp value) 1333 (value (nth 1 split))
1282 (cdr (assq value nnmail-split-abbrev-alist)) 1334 (regexp (concat "^\\(\\("
1283 value) 1335 (if (symbolp field)
1284 "\\)\\>"))) 1336 (cdr (assq field nnmail-split-abbrev-alist))
1285 (push (cons split regexp) nnmail-split-cache) 1337 field)
1286 ;; Now that it's in the cache, just call nnmail-split-it again 1338 "\\):.*\\)\\<\\("
1287 ;; on the same split, which will find it immediately in the cache. 1339 (if (symbolp value)
1288 (nnmail-split-it split))))) 1340 (cdr (assq value nnmail-split-abbrev-alist))
1341 value)
1342 "\\)\\>")))
1343 (push (cons split regexp) nnmail-split-cache)
1344 ;; Now that it's in the cache, just call nnmail-split-it again
1345 ;; on the same split, which will find it immediately in the cache.
1346 (nnmail-split-it split))))))
1289 1347
1290(defun nnmail-expand-newtext (newtext) 1348(defun nnmail-expand-newtext (newtext)
1291 (let ((len (length newtext)) 1349 (let ((len (length newtext))
@@ -1299,14 +1357,14 @@ See the documentation for the variable `nnmail-split-fancy' for documentation."
1299 (unless (= beg pos) 1357 (unless (= beg pos)
1300 (push (substring newtext beg pos) expanded)) 1358 (push (substring newtext beg pos) expanded))
1301 (when (< pos len) 1359 (when (< pos len)
1302 ;; we hit a \, expand it. 1360 ;; We hit a \; expand it.
1303 (setq did-expand t) 1361 (setq did-expand t
1304 (setq pos (1+ pos)) 1362 pos (1+ pos)
1305 (setq c (aref newtext pos)) 1363 c (aref newtext pos))
1306 (if (not (or (= c ?\&) 1364 (if (not (or (= c ?\&)
1307 (and (>= c ?1) 1365 (and (>= c ?1)
1308 (<= c ?9)))) 1366 (<= c ?9))))
1309 ;; \ followed by some character we don't expand 1367 ;; \ followed by some character we don't expand.
1310 (push (char-to-string c) expanded) 1368 (push (char-to-string c) expanded)
1311 ;; \& or \N 1369 ;; \& or \N
1312 (if (= c ?\&) 1370 (if (= c ?\&)
@@ -1333,7 +1391,7 @@ See the documentation for the variable `nnmail-split-fancy' for documentation."
1333 nnmail-use-procmail) 1391 nnmail-use-procmail)
1334 (directory-files 1392 (directory-files
1335 nnmail-procmail-directory 1393 nnmail-procmail-directory
1336 t (concat (if group (concat "^" group) "") 1394 t (concat (if group (concat "^" (regexp-quote group)) "")
1337 nnmail-procmail-suffix "$")))) 1395 nnmail-procmail-suffix "$"))))
1338 (p procmails) 1396 (p procmails)
1339 (crash (when (and (file-exists-p nnmail-crash-box) 1397 (crash (when (and (file-exists-p nnmail-crash-box)
@@ -1386,6 +1444,7 @@ See the documentation for the variable `nnmail-split-fancy' for documentation."
1386;; If FORCE, re-read the active file even if the backend is 1444;; If FORCE, re-read the active file even if the backend is
1387;; already activated. 1445;; already activated.
1388(defun nnmail-activate (backend &optional force) 1446(defun nnmail-activate (backend &optional force)
1447 (nnheader-init-server-buffer)
1389 (let (file timestamp file-time) 1448 (let (file timestamp file-time)
1390 (if (or (not (symbol-value (intern (format "%s-group-alist" backend)))) 1449 (if (or (not (symbol-value (intern (format "%s-group-alist" backend))))
1391 force 1450 force
@@ -1531,12 +1590,9 @@ See the documentation for the variable `nnmail-split-fancy' for documentation."
1531(defun nnmail-get-new-mail (method exit-func temp 1590(defun nnmail-get-new-mail (method exit-func temp
1532 &optional group spool-func) 1591 &optional group spool-func)
1533 "Read new incoming mail." 1592 "Read new incoming mail."
1534 ;; Nix out the previous split history.
1535 (unless group
1536 (setq nnmail-split-history nil))
1537 (let* ((spools (nnmail-get-spool-files group)) 1593 (let* ((spools (nnmail-get-spool-files group))
1538 (group-in group) 1594 (group-in group)
1539 incoming incomings spool) 1595 nnmail-current-spool incoming incomings spool)
1540 (when (and (nnmail-get-value "%s-get-new-mail" method) 1596 (when (and (nnmail-get-value "%s-get-new-mail" method)
1541 nnmail-spool-file) 1597 nnmail-spool-file)
1542 ;; We first activate all the groups. 1598 ;; We first activate all the groups.
@@ -1558,6 +1614,7 @@ See the documentation for the variable `nnmail-split-fancy' for documentation."
1558 (nnheader-message 3 "%s: Reading incoming mail..." method) 1614 (nnheader-message 3 "%s: Reading incoming mail..." method)
1559 (when (and (nnmail-move-inbox spool) 1615 (when (and (nnmail-move-inbox spool)
1560 (file-exists-p nnmail-crash-box)) 1616 (file-exists-p nnmail-crash-box))
1617 (setq nnmail-current-spool spool)
1561 ;; There is new mail. We first find out if all this mail 1618 ;; There is new mail. We first find out if all this mail
1562 ;; is supposed to go to some specific group. 1619 ;; is supposed to go to some specific group.
1563 (setq group (nnmail-get-split-group spool group-in)) 1620 (setq group (nnmail-get-split-group spool group-in))
@@ -1575,6 +1632,8 @@ See the documentation for the variable `nnmail-split-fancy' for documentation."
1575 (file-name-nondirectory 1632 (file-name-nondirectory
1576 (concat (file-name-as-directory temp) "Incoming"))) 1633 (concat (file-name-as-directory temp) "Incoming")))
1577 (concat (file-name-as-directory temp) "Incoming"))))) 1634 (concat (file-name-as-directory temp) "Incoming")))))
1635 (unless (file-exists-p (file-name-directory incoming))
1636 (make-directory (file-name-directory incoming) t))
1578 (rename-file nnmail-crash-box incoming t) 1637 (rename-file nnmail-crash-box incoming t)
1579 (push incoming incomings)))) 1638 (push incoming incomings))))
1580 ;; If we did indeed read any incoming spools, we save all info. 1639 ;; If we did indeed read any incoming spools, we save all info.
@@ -1647,11 +1706,8 @@ If ARGS, PROMPT is used as an argument to `format'."
1647 1706
1648(defun nnmail-write-region (start end filename &optional append visit lockname) 1707(defun nnmail-write-region (start end filename &optional append visit lockname)
1649 "Do a `write-region', and then set the file modes." 1708 "Do a `write-region', and then set the file modes."
1650 ;; 1997/5/4 by MORIOKA Tomohiko <morioka@jaist.ac.jp>
1651 (let ((coding-system-for-write nnmail-file-coding-system) 1709 (let ((coding-system-for-write nnmail-file-coding-system)
1652 ;; 1997/8/12 by MORIOKA Tomohiko 1710 (pathname-coding-system 'binary))
1653 (file-name-coding-system 'binary) ; for Emacs 20
1654 (pathname-coding-system 'binary)) ; for XEmacs/mule
1655 (write-region start end filename append visit lockname) 1711 (write-region start end filename append visit lockname)
1656 (set-file-modes filename nnmail-default-file-modes))) 1712 (set-file-modes filename nnmail-default-file-modes)))
1657 1713
@@ -1729,6 +1785,15 @@ If ARGS, PROMPT is used as an argument to `format'."
1729 ", ")) 1785 ", "))
1730 (princ "\n"))))) 1786 (princ "\n")))))
1731 1787
1788(defun nnmail-purge-split-history (group)
1789 "Remove all instances of GROUP from `nnmail-split-history'."
1790 (let ((history nnmail-split-history))
1791 (while history
1792 (setcar history (gnus-delete-if (lambda (e) (string= (car e) group))
1793 (car history)))
1794 (pop history))
1795 (setq nnmail-split-history (delq nil nnmail-split-history))))
1796
1732(defun nnmail-new-mail-p (group) 1797(defun nnmail-new-mail-p (group)
1733 "Say whether GROUP has new mail." 1798 "Say whether GROUP has new mail."
1734 (let ((his nnmail-split-history) 1799 (let ((his nnmail-split-history)
@@ -1748,6 +1813,14 @@ If ARGS, PROMPT is used as an argument to `format'."
1748 (substring inbox (match-end (string-match "^po:" inbox))))) 1813 (substring inbox (match-end (string-match "^po:" inbox)))))
1749 (pop3-movemail crashbox))) 1814 (pop3-movemail crashbox)))
1750 1815
1816(defun nnmail-within-headers-p ()
1817 "Check to see if point is within the headers of a unix mail message.
1818Doesn't change point."
1819 (let ((pos (point)))
1820 (save-excursion
1821 (and (nnmail-search-unix-mail-delim-backward)
1822 (not (search-forward "\n\n" pos t))))))
1823
1751(run-hooks 'nnmail-load-hook) 1824(run-hooks 'nnmail-load-hook)
1752 1825
1753(provide 'nnmail) 1826(provide 'nnmail)
diff --git a/lisp/gnus/nnmbox.el b/lisp/gnus/nnmbox.el
index a5c46769e3c..1f05d1d16b5 100644
--- a/lisp/gnus/nnmbox.el
+++ b/lisp/gnus/nnmbox.el
@@ -1,7 +1,7 @@
1;;; nnmbox.el --- mail mbox access for Gnus 1;;; nnmbox.el --- mail mbox access for Gnus
2;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. 2;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> 5;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
6;; Keywords: news, mail 6;; Keywords: news, mail
7 7
@@ -12,11 +12,6 @@
12;; the Free Software Foundation; either version 2, or (at your option) 12;; the Free Software Foundation; either version 2, or (at your option)
13;; any later version. 13;; any later version.
14 14
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License 15;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs; see the file COPYING. If not, write to the 16;; along with GNU Emacs; see the file COPYING. If not, write to the
22;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 17;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
@@ -207,6 +202,14 @@
207(deffoo nnmbox-close-group (group &optional server) 202(deffoo nnmbox-close-group (group &optional server)
208 t) 203 t)
209 204
205(deffoo nnmbox-request-create-group (group &optional server args)
206 (nnmail-activate 'nnmbox)
207 (unless (assoc group nnmbox-group-alist)
208 (push (list group (cons 1 0))
209 nnmbox-group-alist)
210 (nnmail-save-active nnmbox-group-alist nnmbox-active-file))
211 t)
212
210(deffoo nnmbox-request-list (&optional server) 213(deffoo nnmbox-request-list (&optional server)
211 (save-excursion 214 (save-excursion
212 (nnmail-find-file nnmbox-active-file) 215 (nnmail-find-file nnmbox-active-file)
diff --git a/lisp/gnus/nnmh.el b/lisp/gnus/nnmh.el
index bf4363de717..30069a154c2 100644
--- a/lisp/gnus/nnmh.el
+++ b/lisp/gnus/nnmh.el
@@ -1,7 +1,7 @@
1;;; nnmh.el --- mhspool access for Gnus 1;;; nnmh.el --- mhspool access for Gnus
2;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. 2;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> 5;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
6;; Keywords: news, mail 6;; Keywords: news, mail
7 7
@@ -60,6 +60,7 @@
60 60
61(defvoo nnmh-status-string "") 61(defvoo nnmh-status-string "")
62(defvoo nnmh-group-alist nil) 62(defvoo nnmh-group-alist nil)
63(defvoo nnmh-allow-delete-final nil)
63 64
64 65
65 66
@@ -76,9 +77,8 @@
76 (large (and (numberp nnmail-large-newsgroup) 77 (large (and (numberp nnmail-large-newsgroup)
77 (> number nnmail-large-newsgroup))) 78 (> number nnmail-large-newsgroup)))
78 (count 0) 79 (count 0)
79 ;; 1997/8/12 by MORIOKA Tomohiko 80 (file-name-coding-system 'binary)
80 (file-name-coding-system 'binary) ; for Emacs 20 81 (pathname-coding-system 'binary)
81 (pathname-coding-system 'binary) ; for XEmacs/mule
82 beg article) 82 beg article)
83 (nnmh-possibly-change-directory newsgroup server) 83 (nnmh-possibly-change-directory newsgroup server)
84 ;; We don't support fetching by Message-ID. 84 ;; We don't support fetching by Message-ID.
@@ -105,11 +105,11 @@
105 105
106 (and large 106 (and large
107 (zerop (% count 20)) 107 (zerop (% count 20))
108 (message "nnmh: Receiving headers... %d%%" 108 (nnheader-message 5 "nnmh: Receiving headers... %d%%"
109 (/ (* count 100) number)))) 109 (/ (* count 100) number))))
110 110
111 (when large 111 (when large
112 (message "nnmh: Receiving headers...done")) 112 (nnheader-message 5 "nnmh: Receiving headers...done"))
113 113
114 (nnheader-fold-continuation-lines) 114 (nnheader-fold-continuation-lines)
115 'headers)))) 115 'headers))))
@@ -137,9 +137,8 @@
137 (let ((file (if (stringp id) 137 (let ((file (if (stringp id)
138 nil 138 nil
139 (concat nnmh-current-directory (int-to-string id)))) 139 (concat nnmh-current-directory (int-to-string id))))
140 ;; 1997/8/12 by MORIOKA Tomohiko 140 (pathname-coding-system 'binary)
141 (file-name-coding-system 'binary) ; for Emacs 20 141 (file-name-coding-system 'binary)
142 (pathname-coding-system 'binary) ; for XEmacs/mule
143 (nntp-server-buffer (or buffer nntp-server-buffer))) 142 (nntp-server-buffer (or buffer nntp-server-buffer)))
144 (and (stringp file) 143 (and (stringp file)
145 (file-exists-p file) 144 (file-exists-p file)
@@ -148,10 +147,11 @@
148 (string-to-int (file-name-nondirectory file))))) 147 (string-to-int (file-name-nondirectory file)))))
149 148
150(deffoo nnmh-request-group (group &optional server dont-check) 149(deffoo nnmh-request-group (group &optional server dont-check)
150 (nnheader-init-server-buffer)
151 (nnmh-possibly-change-directory group server)
151 (let ((pathname (nnmail-group-pathname group nnmh-directory)) 152 (let ((pathname (nnmail-group-pathname group nnmh-directory))
152 ;; 1997/8/12 by MORIOKA Tomohiko 153 (pathname-coding-system 'binary)
153 (file-name-coding-system 'binary) ; for Emacs 20 154 (file-name-coding-system 'binary)
154 (pathname-coding-system 'binary) ; for XEmacs/mule.
155 dir) 155 dir)
156 (cond 156 (cond
157 ((not (file-directory-p pathname)) 157 ((not (file-directory-p pathname))
@@ -190,10 +190,11 @@
190 190
191(deffoo nnmh-request-list (&optional server dir) 191(deffoo nnmh-request-list (&optional server dir)
192 (nnheader-insert "") 192 (nnheader-insert "")
193 (let ((file-name-coding-system 'binary) 193 (nnmh-possibly-change-directory nil server)
194 (pathname-coding-system 'binary) 194 (let* ((pathname-coding-system 'binary)
195 (nnmh-toplev 195 (file-name-coding-system 'binary)
196 (file-truename (or dir (file-name-as-directory nnmh-directory))))) 196 (nnmh-toplev
197 (file-truename (or dir (file-name-as-directory nnmh-directory)))))
197 (nnmh-request-list-1 nnmh-toplev)) 198 (nnmh-request-list-1 nnmh-toplev))
198 (setq nnmh-group-alist (nnmail-get-active)) 199 (setq nnmh-group-alist (nnmail-get-active))
199 t) 200 t)
@@ -204,14 +205,15 @@
204 ;; Recurse down all directories. 205 ;; Recurse down all directories.
205 (let ((dirs (and (file-readable-p dir) 206 (let ((dirs (and (file-readable-p dir)
206 (> (nth 1 (file-attributes (file-chase-links dir))) 2) 207 (> (nth 1 (file-attributes (file-chase-links dir))) 2)
207 (directory-files dir t nil t))) 208 (nnheader-directory-files dir t nil t)))
208 dir) 209 rdir)
209 ;; Recurse down directories. 210 ;; Recurse down directories.
210 (while (setq dir (pop dirs)) 211 (while (setq rdir (pop dirs))
211 (when (and (not (member (file-name-nondirectory dir) '("." ".."))) 212 (when (and (file-directory-p rdir)
212 (file-directory-p dir) 213 (file-readable-p rdir)
213 (file-readable-p dir)) 214 (not (equal (file-truename rdir)
214 (nnmh-request-list-1 dir)))) 215 (file-truename dir))))
216 (nnmh-request-list-1 rdir))))
215 ;; For each directory, generate an active file line. 217 ;; For each directory, generate an active file line.
216 (unless (string= (expand-file-name nnmh-toplev) dir) 218 (unless (string= (expand-file-name nnmh-toplev) dir)
217 (let ((files (mapcar 219 (let ((files (mapcar
@@ -231,8 +233,8 @@
231 (expand-file-name nnmh-toplev)))) 233 (expand-file-name nnmh-toplev))))
232 dir) 234 dir)
233 (nnheader-replace-chars-in-string 235 (nnheader-replace-chars-in-string
234 (decode-coding-string (substring dir (match-end 0)) 236 (gnus-decode-coding-string (substring dir (match-end 0))
235 nnmail-pathname-coding-system) 237 nnmail-pathname-coding-system)
236 ?/ ?.)) 238 ?/ ?.))
237 (apply 'max files) 239 (apply 'max files)
238 (apply 'min files))))))) 240 (apply 'min files)))))))
@@ -244,15 +246,9 @@
244(deffoo nnmh-request-expire-articles (articles newsgroup 246(deffoo nnmh-request-expire-articles (articles newsgroup
245 &optional server force) 247 &optional server force)
246 (nnmh-possibly-change-directory newsgroup server) 248 (nnmh-possibly-change-directory newsgroup server)
247 (let* ((active-articles 249 (let* ((is-old t)
248 (mapcar
249 (function
250 (lambda (name)
251 (string-to-int name)))
252 (directory-files nnmh-current-directory nil "^[0-9]+$" t)))
253 (is-old t)
254 article rest mod-time) 250 article rest mod-time)
255 (nnmail-activate 'nnmh) 251 (nnheader-init-server-buffer)
256 252
257 (while (and articles is-old) 253 (while (and articles is-old)
258 (setq article (concat nnmh-current-directory 254 (setq article (concat nnmh-current-directory
@@ -272,7 +268,7 @@
272 (push (car articles) rest)))) 268 (push (car articles) rest))))
273 (push (car articles) rest))) 269 (push (car articles) rest)))
274 (setq articles (cdr articles))) 270 (setq articles (cdr articles)))
275 (message "") 271 (nnheader-message 5 "")
276 (nconc rest articles))) 272 (nconc rest articles)))
277 273
278(deffoo nnmh-close-group (group &optional server) 274(deffoo nnmh-close-group (group &optional server)
@@ -305,20 +301,19 @@
305 (nnmail-check-syntax) 301 (nnmail-check-syntax)
306 (when nnmail-cache-accepted-message-ids 302 (when nnmail-cache-accepted-message-ids
307 (nnmail-cache-insert (nnmail-fetch-field "message-id"))) 303 (nnmail-cache-insert (nnmail-fetch-field "message-id")))
304 (nnheader-init-server-buffer)
308 (prog1 305 (prog1
309 (if (stringp group) 306 (if (stringp group)
310 (and 307 (if noinsert
311 (nnmail-activate 'nnmh) 308 (nnmh-active-number group)
312 (car (nnmh-save-mail 309 (car (nnmh-save-mail
313 (list (cons group (nnmh-active-number group))) 310 (list (cons group (nnmh-active-number group)))
314 noinsert))) 311 noinsert)))
315 (and 312 (let ((res (nnmail-article-group 'nnmh-active-number)))
316 (nnmail-activate 'nnmh) 313 (if (and (null res)
317 (let ((res (nnmail-article-group 'nnmh-active-number))) 314 (yes-or-no-p "Moved to `junk' group; delete article? "))
318 (if (and (null res) 315 'junk
319 (yes-or-no-p "Moved to `junk' group; delete article? ")) 316 (car (nnmh-save-mail res noinsert)))))
320 'junk
321 (car (nnmh-save-mail res noinsert))))))
322 (when (and last nnmail-cache-accepted-message-ids) 317 (when (and last nnmail-cache-accepted-message-ids)
323 (nnmail-cache-close)))) 318 (nnmail-cache-close))))
324 319
@@ -335,7 +330,7 @@
335 t))) 330 t)))
336 331
337(deffoo nnmh-request-create-group (group &optional server args) 332(deffoo nnmh-request-create-group (group &optional server args)
338 (nnmail-activate 'nnmh) 333 (nnheader-init-server-buffer)
339 (unless (assoc group nnmh-group-alist) 334 (unless (assoc group nnmh-group-alist)
340 (let (active) 335 (let (active)
341 (push (list group (setq active (cons 1 0))) 336 (push (list group (setq active (cons 1 0)))
@@ -410,9 +405,8 @@
410 (nnmh-open-server server)) 405 (nnmh-open-server server))
411 (when newsgroup 406 (when newsgroup
412 (let ((pathname (nnmail-group-pathname newsgroup nnmh-directory)) 407 (let ((pathname (nnmail-group-pathname newsgroup nnmh-directory))
413 ;; 1997/8/12 by MORIOKA Tomohiko 408 (file-name-coding-system 'binary)
414 (file-name-coding-system 'binary) ; for Emacs 20 409 (pathname-coding-system 'binary))
415 (pathname-coding-system 'binary)) ; for XEmacs/mule
416 (if (file-directory-p pathname) 410 (if (file-directory-p pathname)
417 (setq nnmh-current-directory pathname) 411 (setq nnmh-current-directory pathname)
418 (error "No such newsgroup: %s" newsgroup))))) 412 (error "No such newsgroup: %s" newsgroup)))))
@@ -461,16 +455,15 @@
461 "Compute the next article number in GROUP." 455 "Compute the next article number in GROUP."
462 (let ((active (cadr (assoc group nnmh-group-alist))) 456 (let ((active (cadr (assoc group nnmh-group-alist)))
463 (dir (nnmail-group-pathname group nnmh-directory)) 457 (dir (nnmail-group-pathname group nnmh-directory))
464 ;; 1997/8/14 by MORIOKA Tomohiko 458 (file-name-coding-system 'binary)
465 (file-name-coding-system 'binary) ; for Emacs 20 459 (pathname-coding-system 'binary))
466 (pathname-coding-system 'binary)) ; for XEmacs/mule
467 (unless active 460 (unless active
468 ;; The group wasn't known to nnmh, so we just create an active 461 ;; The group wasn't known to nnmh, so we just create an active
469 ;; entry for it. 462 ;; entry for it.
470 (setq active (cons 1 0)) 463 (setq active (cons 1 0))
471 (push (list group active) nnmh-group-alist) 464 (push (list group active) nnmh-group-alist)
472 (unless (file-exists-p dir) 465 (unless (file-exists-p dir)
473 (make-directory dir)) 466 (gnus-make-directory dir))
474 ;; Find the highest number in the group. 467 ;; Find the highest number in the group.
475 (let ((files (sort 468 (let ((files (sort
476 (mapcar 469 (mapcar
@@ -557,9 +550,12 @@
557 (let ((path (concat nnmh-current-directory (int-to-string article)))) 550 (let ((path (concat nnmh-current-directory (int-to-string article))))
558 ;; Writable. 551 ;; Writable.
559 (and (file-writable-p path) 552 (and (file-writable-p path)
560 ;; We can never delete the last article in the group. 553 (or
561 (not (eq (cdr (nth 1 (assoc group nnmh-group-alist))) 554 ;; We can never delete the last article in the group.
562 article))))) 555 (not (eq (cdr (nth 1 (assoc group nnmh-group-alist)))
556 article))
557 ;; Well, we can.
558 nnmh-allow-delete-final))))
563 559
564(provide 'nnmh) 560(provide 'nnmh)
565 561
diff --git a/lisp/gnus/nnml.el b/lisp/gnus/nnml.el
index 6819086fa6c..59b911f0537 100644
--- a/lisp/gnus/nnml.el
+++ b/lisp/gnus/nnml.el
@@ -1,7 +1,7 @@
1;;; nnml.el --- mail spool access for Gnus 1;;; nnml.el --- mail spool access for Gnus
2;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. 2;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> 5;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
6;; Keywords: news, mail 6;; Keywords: news, mail
7 7
@@ -84,6 +84,8 @@ all. This may very well take some time.")
84 84
85(defvoo nnml-generate-active-function 'nnml-generate-active-info) 85(defvoo nnml-generate-active-function 'nnml-generate-active-info)
86 86
87(defvar nnml-nov-buffer-file-name nil)
88
87 89
88 90
89;;; Interface functions. 91;;; Interface functions.
@@ -98,9 +100,8 @@ all. This may very well take some time.")
98 (let ((file nil) 100 (let ((file nil)
99 (number (length sequence)) 101 (number (length sequence))
100 (count 0) 102 (count 0)
101 ;; 1997/8/12 by MORIOKA Tomohiko 103 (file-name-coding-system 'binary)
102 (file-name-coding-system 'binary) ; for Emacs 20 104 (pathname-coding-system 'binary)
103 (pathname-coding-system 'binary) ; for XEmacs/mule
104 beg article) 105 beg article)
105 (if (stringp (car sequence)) 106 (if (stringp (car sequence))
106 'headers 107 'headers
@@ -163,9 +164,8 @@ all. This may very well take some time.")
163(deffoo nnml-request-article (id &optional group server buffer) 164(deffoo nnml-request-article (id &optional group server buffer)
164 (nnml-possibly-change-directory group server) 165 (nnml-possibly-change-directory group server)
165 (let* ((nntp-server-buffer (or buffer nntp-server-buffer)) 166 (let* ((nntp-server-buffer (or buffer nntp-server-buffer))
166 ;; 1997/8/12 by MORIOKA Tomohiko 167 (file-name-coding-system 'binary)
167 (file-name-coding-system 'binary) ; for Emacs 20 168 (pathname-coding-system 'binary)
168 (pathname-coding-system 'binary) ; for XEmacs/mule
169 path gpath group-num) 169 path gpath group-num)
170 (if (stringp id) 170 (if (stringp id)
171 (when (and (setq group-num (nnml-find-group-number id)) 171 (when (and (setq group-num (nnml-find-group-number id))
@@ -194,9 +194,8 @@ all. This may very well take some time.")
194 (string-to-int (file-name-nondirectory path))))))) 194 (string-to-int (file-name-nondirectory path)))))))
195 195
196(deffoo nnml-request-group (group &optional server dont-check) 196(deffoo nnml-request-group (group &optional server dont-check)
197 ;; 1997/8/12 by MORIOKA Tomohiko 197 (let ((pathname-coding-system 'binary)
198 (let ((file-name-coding-system 'binary) ; for Emacs 20 198 (file-name-coding-system 'binary))
199 (pathname-coding-system 'binary)) ; for XEmacs/mule
200 (cond 199 (cond
201 ((not (nnml-possibly-change-directory group server)) 200 ((not (nnml-possibly-change-directory group server))
202 (nnheader-report 'nnml "Invalid group (no such directory)")) 201 (nnheader-report 'nnml "Invalid group (no such directory)"))
@@ -230,7 +229,14 @@ all. This may very well take some time.")
230 229
231(deffoo nnml-request-create-group (group &optional server args) 230(deffoo nnml-request-create-group (group &optional server args)
232 (nnmail-activate 'nnml) 231 (nnmail-activate 'nnml)
233 (unless (assoc group nnml-group-alist) 232 (cond
233 ((assoc group nnml-group-alist)
234 t)
235 ((and (file-exists-p (nnmail-group-pathname group nnml-directory))
236 (not (file-directory-p (nnmail-group-pathname group nnml-directory))))
237 (nnheader-report 'nnml "%s is a file"
238 (nnmail-group-pathname group nnml-directory)))
239 (t
234 (let (active) 240 (let (active)
235 (push (list group (setq active (cons 1 0))) 241 (push (list group (setq active (cons 1 0)))
236 nnml-group-alist) 242 nnml-group-alist)
@@ -240,16 +246,14 @@ all. This may very well take some time.")
240 (when articles 246 (when articles
241 (setcar active (apply 'min articles)) 247 (setcar active (apply 'min articles))
242 (setcdr active (apply 'max articles)))) 248 (setcdr active (apply 'max articles))))
243 (nnmail-save-active nnml-group-alist nnml-active-file))) 249 (nnmail-save-active nnml-group-alist nnml-active-file)
244 t) 250 t))))
245 251
246(deffoo nnml-request-list (&optional server) 252(deffoo nnml-request-list (&optional server)
247 (save-excursion 253 (save-excursion
248 ;; 1997/8/12 by MORIOKA Tomohiko
249 ;; for XEmacs/mule.
250 (let ((nnmail-file-coding-system nnmail-active-file-coding-system) 254 (let ((nnmail-file-coding-system nnmail-active-file-coding-system)
251 (file-name-coding-system 'binary) ; for Emacs 20 255 (file-name-coding-system 'binary)
252 (pathname-coding-system 'binary)) ; for XEmacs/mule 256 (pathname-coding-system 'binary))
253 (nnmail-find-file nnml-active-file) 257 (nnmail-find-file nnml-active-file)
254 ) 258 )
255 (setq nnml-group-alist (nnmail-get-active)) 259 (setq nnml-group-alist (nnmail-get-active))
@@ -265,12 +269,17 @@ all. This may very well take some time.")
265(deffoo nnml-request-expire-articles (articles group 269(deffoo nnml-request-expire-articles (articles group
266 &optional server force) 270 &optional server force)
267 (nnml-possibly-change-directory group server) 271 (nnml-possibly-change-directory group server)
268 (let* ((active-articles 272 (let ((active-articles
269 (nnheader-directory-articles nnml-current-directory)) 273 (nnheader-directory-articles nnml-current-directory))
270 (is-old t) 274 (is-old t)
271 article rest mod-time number) 275 article rest mod-time number)
272 (nnmail-activate 'nnml) 276 (nnmail-activate 'nnml)
273 277
278 (setq active-articles (sort active-articles '<))
279 ;; Articles not listed in active-articles are already gone,
280 ;; so don't try to expire them.
281 (setq articles (gnus-sorted-intersection articles active-articles))
282
274 (while (and articles is-old) 283 (while (and articles is-old)
275 (when (setq article (nnml-article-to-file (setq number (pop articles)))) 284 (when (setq article (nnml-article-to-file (setq number (pop articles))))
276 (when (setq mod-time (nth 5 (file-attributes article))) 285 (when (setq mod-time (nth 5 (file-attributes article)))
@@ -480,8 +489,8 @@ all. This may very well take some time.")
480 ;; Just to make sure nothing went wrong when reading over NFS -- 489 ;; Just to make sure nothing went wrong when reading over NFS --
481 ;; check once more. 490 ;; check once more.
482 (when (file-exists-p 491 (when (file-exists-p
483 (setq file (concat nnml-current-directory "/" 492 (setq file (expand-file-name (number-to-string article)
484 (number-to-string article)))) 493 nnml-current-directory)))
485 (nnml-update-file-alist t) 494 (nnml-update-file-alist t)
486 file)))) 495 file))))
487 496
@@ -563,9 +572,8 @@ all. This may very well take some time.")
563 (if (not group) 572 (if (not group)
564 t 573 t
565 (let ((pathname (nnmail-group-pathname group nnml-directory)) 574 (let ((pathname (nnmail-group-pathname group nnml-directory))
566 ;; 1997/8/14 by MORIOKA Tomohiko 575 (file-name-coding-system 'binary)
567 (file-name-coding-system 'binary) ; for Emacs 20 576 (pathname-coding-system 'binary))
568 (pathname-coding-system 'binary)) ; for XEmacs/mule
569 (when (not (equal pathname nnml-current-directory)) 577 (when (not (equal pathname nnml-current-directory))
570 (setq nnml-current-directory pathname 578 (setq nnml-current-directory pathname
571 nnml-current-group group 579 nnml-current-group group
@@ -635,7 +643,7 @@ all. This may very well take some time.")
635 (setq nnml-article-file-alist 643 (setq nnml-article-file-alist
636 (sort 644 (sort
637 (nnheader-article-to-file-alist nnml-current-directory) 645 (nnheader-article-to-file-alist nnml-current-directory)
638 (lambda (a1 a2) (< (car a1) (car a2)))))) 646 'car-less-than-car)))
639 (setq active 647 (setq active
640 (if nnml-article-file-alist 648 (if nnml-article-file-alist
641 (cons (caar nnml-article-file-alist) 649 (cons (caar nnml-article-file-alist)
@@ -664,10 +672,10 @@ all. This may very well take some time.")
664 "Parse the head of the current buffer." 672 "Parse the head of the current buffer."
665 (save-excursion 673 (save-excursion
666 (save-restriction 674 (save-restriction
667 (goto-char (point-min)) 675 (unless (zerop (buffer-size))
668 (narrow-to-region 676 (narrow-to-region
669 (point) 677 (goto-char (point-min))
670 (1- (or (search-forward "\n\n" nil t) (point-max)))) 678 (if (search-forward "\n\n" nil t) (1- (point)) (point-max))))
671 ;; Fold continuation lines. 679 ;; Fold continuation lines.
672 (goto-char (point-min)) 680 (goto-char (point-min))
673 (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t) 681 (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
@@ -681,12 +689,15 @@ all. This may very well take some time.")
681 689
682(defun nnml-open-nov (group) 690(defun nnml-open-nov (group)
683 (or (cdr (assoc group nnml-nov-buffer-alist)) 691 (or (cdr (assoc group nnml-nov-buffer-alist))
684 (let ((buffer (nnheader-find-file-noselect 692 (let ((buffer (get-buffer-create (format " *nnml overview %s*" group))))
685 (concat (nnmail-group-pathname group nnml-directory)
686 nnml-nov-file-name))))
687 (save-excursion 693 (save-excursion
688 (set-buffer buffer) 694 (set-buffer buffer)
689 (buffer-disable-undo (current-buffer))) 695 (set (make-local-variable 'nnml-nov-buffer-file-name)
696 (concat (nnmail-group-pathname group nnml-directory)
697 nnml-nov-file-name))
698 (erase-buffer)
699 (when (file-exists-p nnml-nov-buffer-file-name)
700 (nnheader-insert-file-contents nnml-nov-buffer-file-name)))
690 (push (cons group buffer) nnml-nov-buffer-alist) 701 (push (cons group buffer) nnml-nov-buffer-alist)
691 buffer))) 702 buffer)))
692 703
@@ -696,7 +707,8 @@ all. This may very well take some time.")
696 (when (buffer-name (cdar nnml-nov-buffer-alist)) 707 (when (buffer-name (cdar nnml-nov-buffer-alist))
697 (set-buffer (cdar nnml-nov-buffer-alist)) 708 (set-buffer (cdar nnml-nov-buffer-alist))
698 (when (buffer-modified-p) 709 (when (buffer-modified-p)
699 (nnmail-write-region 1 (point-max) (buffer-file-name) nil 'nomesg)) 710 (nnmail-write-region 1 (point-max) nnml-nov-buffer-file-name
711 nil 'nomesg))
700 (set-buffer-modified-p nil) 712 (set-buffer-modified-p nil)
701 (kill-buffer (current-buffer))) 713 (kill-buffer (current-buffer)))
702 (setq nnml-nov-buffer-alist (cdr nnml-nov-buffer-alist))))) 714 (setq nnml-nov-buffer-alist (cdr nnml-nov-buffer-alist)))))
@@ -731,8 +743,13 @@ all. This may very well take some time.")
731 (nnml-generate-nov-databases-1 dir seen)))) 743 (nnml-generate-nov-databases-1 dir seen))))
732 ;; Do this directory. 744 ;; Do this directory.
733 (let ((files (sort (nnheader-article-to-file-alist dir) 745 (let ((files (sort (nnheader-article-to-file-alist dir)
734 (lambda (a b) (< (car a) (car b)))))) 746 'car-less-than-car)))
735 (when files 747 (if (not files)
748 (let* ((group (nnheader-file-to-group
749 (directory-file-name dir) nnml-directory))
750 (info (cadr (assoc group nnml-group-alist))))
751 (when info
752 (setcar info (1+ (cdr info)))))
736 (funcall nnml-generate-active-function dir) 753 (funcall nnml-generate-active-function dir)
737 ;; Generate the nov file. 754 ;; Generate the nov file.
738 (nnml-generate-nov-file dir files) 755 (nnml-generate-nov-file dir files)
diff --git a/lisp/gnus/nnoo.el b/lisp/gnus/nnoo.el
index d2f271f5c55..9c27786bf68 100644
--- a/lisp/gnus/nnoo.el
+++ b/lisp/gnus/nnoo.el
@@ -1,7 +1,7 @@
1;;; nnoo.el --- OO Gnus Backends 1;;; nnoo.el --- OO Gnus Backends
2;; Copyright (C) 1996,97 Free Software Foundation, Inc. 2;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: news 5;; Keywords: news
6 6
7;; This file is part of GNU Emacs. 7;; This file is part of GNU Emacs.
@@ -30,6 +30,7 @@
30 30
31(defvar nnoo-definition-alist nil) 31(defvar nnoo-definition-alist nil)
32(defvar nnoo-state-alist nil) 32(defvar nnoo-state-alist nil)
33(defvar nnoo-parent-backend nil)
33 34
34(defmacro defvoo (var init &optional doc &rest map) 35(defmacro defvoo (var init &optional doc &rest map)
35 "The same as `defvar', only takes list of variables to MAP to." 36 "The same as `defvar', only takes list of variables to MAP to."
@@ -88,25 +89,42 @@
88 (or (cdr imp) 89 (or (cdr imp)
89 (nnoo-functions (car imp)))) 90 (nnoo-functions (car imp))))
90 (while functions 91 (while functions
91 (unless (fboundp (setq function 92 (unless (fboundp
92 (nnoo-symbol backend (nnoo-rest-symbol 93 (setq function
93 (car functions))))) 94 (nnoo-symbol backend
95 (nnoo-rest-symbol (car functions)))))
94 (eval `(deffoo ,function (&rest args) 96 (eval `(deffoo ,function (&rest args)
95 (,call-function ',backend ',(car functions) args)))) 97 (,call-function ',backend ',(car functions) args))))
96 (pop functions))))) 98 (pop functions)))))
97 99
98(defun nnoo-parent-function (backend function args) 100(defun nnoo-parent-function (backend function args)
99 (let* ((pbackend (nnoo-backend function))) 101 (let ((pbackend (nnoo-backend function))
100 (nnoo-change-server pbackend (nnoo-current-server backend) 102 (nnoo-parent-backend backend))
103 (nnoo-change-server pbackend
104 (nnoo-current-server backend)
101 (cdr (assq pbackend (nnoo-parents backend)))) 105 (cdr (assq pbackend (nnoo-parents backend))))
102 (apply function args))) 106 (prog1
107 (apply function args)
108 ;; Copy the changed variables back into the child.
109 (let ((vars (cdr (assq pbackend (nnoo-parents backend)))))
110 (while vars
111 (set (cadar vars) (symbol-value (caar vars)))
112 (setq vars (cdr vars)))))))
103 113
104(defun nnoo-execute (backend function &rest args) 114(defun nnoo-execute (backend function &rest args)
105 "Execute FUNCTION on behalf of BACKEND." 115 "Execute FUNCTION on behalf of BACKEND."
106 (let* ((pbackend (nnoo-backend function))) 116 (let ((pbackend (nnoo-backend function))
107 (nnoo-change-server pbackend (nnoo-current-server backend) 117 (nnoo-parent-backend backend))
118 (nnoo-change-server pbackend
119 (nnoo-current-server backend)
108 (cdr (assq pbackend (nnoo-parents backend)))) 120 (cdr (assq pbackend (nnoo-parents backend))))
109 (apply function args))) 121 (prog1
122 (apply function args)
123 ;; Copy the changed variables back into the child.
124 (let ((vars (cdr (assq pbackend (nnoo-parents backend)))))
125 (while vars
126 (set (cadar vars) (symbol-value (caar vars)))
127 (setq vars (cdr vars)))))))
110 128
111(defmacro nnoo-map-functions (backend &rest maps) 129(defmacro nnoo-map-functions (backend &rest maps)
112 `(nnoo-map-functions-1 ',backend ',maps)) 130 `(nnoo-map-functions-1 ',backend ',maps))
@@ -157,8 +175,13 @@
157 (let* ((bstate (cdr (assq backend nnoo-state-alist))) 175 (let* ((bstate (cdr (assq backend nnoo-state-alist)))
158 (current (car bstate)) 176 (current (car bstate))
159 (parents (nnoo-parents backend)) 177 (parents (nnoo-parents backend))
178 (server (if nnoo-parent-backend
179 (format "%s+%s" nnoo-parent-backend server)
180 server))
160 (bvariables (nnoo-variables backend)) 181 (bvariables (nnoo-variables backend))
161 state def) 182 state def)
183 ;; If we don't have a current state, we push an empty state
184 ;; onto the alist.
162 (unless bstate 185 (unless bstate
163 (push (setq bstate (list backend nil)) 186 (push (setq bstate (list backend nil))
164 nnoo-state-alist) 187 nnoo-state-alist)
@@ -178,10 +201,12 @@
178 (nconc bvariables 201 (nconc bvariables
179 (list (cons (car def) (and (boundp (car def)) 202 (list (cons (car def) (and (boundp (car def))
180 (symbol-value (car def))))))) 203 (symbol-value (car def)))))))
181 (set (car def) (cadr def)))) 204 (if (equal server "*internal-non-initialized-backend*")
205 (set (car def) (symbol-value (cadr def)))
206 (set (car def) (cadr def)))))
182 (while parents 207 (while parents
183 (nnoo-change-server 208 (nnoo-change-server
184 (caar parents) server 209 (caar parents) (format "%s+%s" backend server)
185 (mapcar (lambda (def) (list (car def) (symbol-value (cadr def)))) 210 (mapcar (lambda (def) (list (car def) (symbol-value (cadr def))))
186 (cdar parents))) 211 (cdar parents)))
187 (pop parents)))) 212 (pop parents))))
@@ -208,7 +233,10 @@
208 (nconc bstate (list (cons current state)))))) 233 (nconc bstate (list (cons current state))))))
209 234
210(defsubst nnoo-current-server-p (backend server) 235(defsubst nnoo-current-server-p (backend server)
211 (equal (nnoo-current-server backend) server)) 236 (equal (nnoo-current-server backend)
237 (if nnoo-parent-backend
238 (format "%s+%s" nnoo-parent-backend server)
239 server)))
212 240
213(defun nnoo-current-server (backend) 241(defun nnoo-current-server (backend)
214 (nth 1 (assq backend nnoo-state-alist))) 242 (nth 1 (assq backend nnoo-state-alist)))
diff --git a/lisp/gnus/nnsoup.el b/lisp/gnus/nnsoup.el
index 31335352e21..e7641509a84 100644
--- a/lisp/gnus/nnsoup.el
+++ b/lisp/gnus/nnsoup.el
@@ -1,7 +1,7 @@
1;;; nnsoup.el --- SOUP access for Gnus 1;;; nnsoup.el --- SOUP access for Gnus
2;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. 2;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> 5;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
6;; Keywords: news, mail 6;; Keywords: news, mail
7 7
@@ -69,6 +69,11 @@ The SOUP packet file name will be inserted at the %s.")
69(defvoo nnsoup-packet-regexp "Soupout" 69(defvoo nnsoup-packet-regexp "Soupout"
70 "*Regular expression matching SOUP packets in `nnsoup-packet-directory'.") 70 "*Regular expression matching SOUP packets in `nnsoup-packet-directory'.")
71 71
72(defvoo nnsoup-always-save t
73 "If non nil commit the reply buffer on each message send.
74This is necessary if using message mode outside Gnus with nnsoup as a
75backend for the messages.")
76
72 77
73 78
74(defconst nnsoup-version "nnsoup 0.0" 79(defconst nnsoup-version "nnsoup 0.0"
@@ -82,7 +87,6 @@ The SOUP packet file name will be inserted at the %s.")
82(defvoo nnsoup-current-group nil) 87(defvoo nnsoup-current-group nil)
83(defvoo nnsoup-group-alist-touched nil) 88(defvoo nnsoup-group-alist-touched nil)
84(defvoo nnsoup-article-alist nil) 89(defvoo nnsoup-article-alist nil)
85
86 90
87 91
88;;; Interface functions. 92;;; Interface functions.
@@ -413,7 +417,7 @@ The SOUP packet file name will be inserted at the %s.")
413 (while (setq area (pop areas)) 417 (while (setq area (pop areas))
414 ;; Change the name to the permanent name and move the files. 418 ;; Change the name to the permanent name and move the files.
415 (setq cur-prefix (nnsoup-next-prefix)) 419 (setq cur-prefix (nnsoup-next-prefix))
416 (message "Incorporating file %s..." cur-prefix) 420 (nnheader-message 5 "Incorporating file %s..." cur-prefix)
417 (when (file-exists-p 421 (when (file-exists-p
418 (setq file (concat nnsoup-tmp-directory 422 (setq file (concat nnsoup-tmp-directory
419 (gnus-soup-area-prefix area) ".IDX"))) 423 (gnus-soup-area-prefix area) ".IDX")))
@@ -544,13 +548,13 @@ The SOUP packet file name will be inserted at the %s.")
544 nnsoup-packet-directory t nnsoup-packet-regexp)) 548 nnsoup-packet-directory t nnsoup-packet-regexp))
545 packet) 549 packet)
546 (while (setq packet (pop packets)) 550 (while (setq packet (pop packets))
547 (message "nnsoup: unpacking %s..." packet) 551 (nnheader-message 5 "nnsoup: unpacking %s..." packet)
548 (if (not (gnus-soup-unpack-packet 552 (if (not (gnus-soup-unpack-packet
549 nnsoup-tmp-directory nnsoup-unpacker packet)) 553 nnsoup-tmp-directory nnsoup-unpacker packet))
550 (message "Couldn't unpack %s" packet) 554 (nnheader-message 5 "Couldn't unpack %s" packet)
551 (delete-file packet) 555 (delete-file packet)
552 (nnsoup-read-areas) 556 (nnsoup-read-areas)
553 (message "Unpacking...done"))))) 557 (nnheader-message 5 "Unpacking...done")))))
554 558
555(defun nnsoup-narrow-to-article (article &optional area head) 559(defun nnsoup-narrow-to-article (article &optional area head)
556 (let* ((area (or area (nnsoup-article-to-area article nnsoup-current-group))) 560 (let* ((area (or area (nnsoup-article-to-area article nnsoup-current-group)))
@@ -614,7 +618,7 @@ The SOUP packet file name will be inserted at the %s.")
614 "Make an outbound package of SOUP replies." 618 "Make an outbound package of SOUP replies."
615 (interactive) 619 (interactive)
616 (unless (file-exists-p nnsoup-replies-directory) 620 (unless (file-exists-p nnsoup-replies-directory)
617 (message "No such directory: %s" nnsoup-replies-directory)) 621 (nnheader-message 5 "No such directory: %s" nnsoup-replies-directory))
618 ;; Write all data buffers. 622 ;; Write all data buffers.
619 (gnus-soup-save-areas) 623 (gnus-soup-save-areas)
620 ;; Write the active file. 624 ;; Write the active file.
@@ -662,6 +666,8 @@ The SOUP packet file name will be inserted at the %s.")
662 (require 'mail-utils) 666 (require 'mail-utils)
663 (let ((tembuf (generate-new-buffer " message temp")) 667 (let ((tembuf (generate-new-buffer " message temp"))
664 (case-fold-search nil) 668 (case-fold-search nil)
669 (real-header-separator mail-header-separator)
670 (mail-header-separator "")
665 delimline 671 delimline
666 (mailbuf (current-buffer))) 672 (mailbuf (current-buffer)))
667 (unwind-protect 673 (unwind-protect
@@ -687,7 +693,7 @@ The SOUP packet file name will be inserted at the %s.")
687 ;; Change header-delimiter to be what sendmail expects. 693 ;; Change header-delimiter to be what sendmail expects.
688 (goto-char (point-min)) 694 (goto-char (point-min))
689 (re-search-forward 695 (re-search-forward
690 (concat "^" (regexp-quote mail-header-separator) "\n")) 696 (concat "^" (regexp-quote real-header-separator) "\n"))
691 (replace-match "\n") 697 (replace-match "\n")
692 (backward-char 1) 698 (backward-char 1)
693 (setq delimline (point-marker)) 699 (setq delimline (point-marker))
@@ -707,8 +713,10 @@ The SOUP packet file name will be inserted at the %s.")
707 (set-buffer msg-buf) 713 (set-buffer msg-buf)
708 (goto-char (point-min)) 714 (goto-char (point-min))
709 (while (re-search-forward "^#! *rnews" nil t) 715 (while (re-search-forward "^#! *rnews" nil t)
710 (incf num))) 716 (incf num))
711 (message "Stored %d messages" num))) 717 (when nnsoup-always-save
718 (save-buffer)))
719 (nnheader-message 5 "Stored %d messages" num)))
712 (nnsoup-write-replies) 720 (nnsoup-write-replies)
713 (kill-buffer tembuf)))))) 721 (kill-buffer tembuf))))))
714 722
@@ -746,7 +754,7 @@ The SOUP packet file name will be inserted at the %s.")
746 (set-buffer (get-buffer-create " *nnsoup work*")) 754 (set-buffer (get-buffer-create " *nnsoup work*"))
747 (buffer-disable-undo (current-buffer)) 755 (buffer-disable-undo (current-buffer))
748 (while files 756 (while files
749 (message "Doing %s..." (car files)) 757 (nnheader-message 5 "Doing %s..." (car files))
750 (erase-buffer) 758 (erase-buffer)
751 (nnheader-insert-file-contents (car files)) 759 (nnheader-insert-file-contents (car files))
752 (goto-char (point-min)) 760 (goto-char (point-min))
@@ -771,7 +779,7 @@ The SOUP packet file name will be inserted at the %s.")
771 (vector ident group "ncm" "" lines)))) 779 (vector ident group "ncm" "" lines))))
772 (setcdr (cadr elem) (+ min lines))) 780 (setcdr (cadr elem) (+ min lines)))
773 (setq files (cdr files))) 781 (setq files (cdr files)))
774 (message "") 782 (nnheader-message 5 "")
775 (setq nnsoup-group-alist active) 783 (setq nnsoup-group-alist active)
776 (nnsoup-write-active-file t))) 784 (nnsoup-write-active-file t)))
777 785
diff --git a/lisp/gnus/nnspool.el b/lisp/gnus/nnspool.el
index 4e2280f0eef..da39914f5d4 100644
--- a/lisp/gnus/nnspool.el
+++ b/lisp/gnus/nnspool.el
@@ -1,8 +1,8 @@
1;;; nnspool.el --- spool access for GNU Emacs 1;;; nnspool.el --- spool access for GNU Emacs
2;; Copyright (C) 1988,89,90,93,94,95,96,97 Free Software Foundation, Inc. 2;; Copyright (C) 1988,89,90,93,94,95,96,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> 4;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
5;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 5;; Lars Magne Ingebrigtsen <larsi@gnus.org>
6;; Keywords: news 6;; Keywords: news
7 7
8;; This file is part of GNU Emacs. 8;; This file is part of GNU Emacs.
@@ -82,6 +82,9 @@ there.")
82(defvoo nnspool-rejected-article-hook nil 82(defvoo nnspool-rejected-article-hook nil
83 "*A hook that will be run when an article has been rejected by the server.") 83 "*A hook that will be run when an article has been rejected by the server.")
84 84
85(defvoo nnspool-file-coding-system nnheader-file-coding-system
86 "Coding system for nnspool.")
87
85;; 1997/8/14 by MORIOKA Tomohiko 88;; 1997/8/14 by MORIOKA Tomohiko
86(defvoo nnspool-file-coding-system nnheader-file-coding-system 89(defvoo nnspool-file-coding-system nnheader-file-coding-system
87 "Coding system for nnspool.") 90 "Coding system for nnspool.")
@@ -113,8 +116,6 @@ there.")
113 (default-directory nnspool-current-directory) 116 (default-directory nnspool-current-directory)
114 (do-message (and (numberp nnspool-large-newsgroup) 117 (do-message (and (numberp nnspool-large-newsgroup)
115 (> number nnspool-large-newsgroup))) 118 (> number nnspool-large-newsgroup)))
116 ;; 1997/8/14 by MORIOKA Tomohiko
117 ;; for Win32
118 (nnheader-file-coding-system nnspool-file-coding-system) 119 (nnheader-file-coding-system nnspool-file-coding-system)
119 file beg article ag) 120 file beg article ag)
120 (if (and (numberp (car articles)) 121 (if (and (numberp (car articles))
@@ -147,11 +148,11 @@ there.")
147 148
148 (and do-message 149 (and do-message
149 (zerop (% (incf count) 20)) 150 (zerop (% (incf count) 20))
150 (message "nnspool: Receiving headers... %d%%" 151 (nnheader-message 5 "nnspool: Receiving headers... %d%%"
151 (/ (* count 100) number)))) 152 (/ (* count 100) number))))
152 153
153 (when do-message 154 (when do-message
154 (message "nnspool: Receiving headers...done")) 155 (nnheader-message 5 "nnspool: Receiving headers...done"))
155 156
156 ;; Fold continuation lines. 157 ;; Fold continuation lines.
157 (nnheader-fold-continuation-lines) 158 (nnheader-fold-continuation-lines)
@@ -346,7 +347,7 @@ there.")
346 (while (re-search-forward "[ \t\n]+" nil t) 347 (while (re-search-forward "[ \t\n]+" nil t)
347 (replace-match " " t t)) 348 (replace-match " " t t))
348 (nnheader-report 'nnspool "%s" (buffer-string)) 349 (nnheader-report 'nnspool "%s" (buffer-string))
349 (message "nnspool: %s" nnspool-status-string) 350 (nnheader-message 5 "nnspool: %s" nnspool-status-string)
350 (ding) 351 (ding)
351 (run-hooks 'nnspool-rejected-article-hook)))) 352 (run-hooks 'nnspool-rejected-article-hook))))
352 353
@@ -356,8 +357,6 @@ there.")
356 (let ((nov (nnheader-group-pathname 357 (let ((nov (nnheader-group-pathname
357 nnspool-current-group nnspool-nov-directory ".overview")) 358 nnspool-current-group nnspool-nov-directory ".overview"))
358 (arts articles) 359 (arts articles)
359 ;; 1997/8/14 by MORIOKA Tomohiko
360 ;; for Win32
361 (nnheader-file-coding-system nnspool-file-coding-system) 360 (nnheader-file-coding-system nnspool-file-coding-system)
362 last) 361 last)
363 (if (not (file-exists-p nov)) 362 (if (not (file-exists-p nov))
@@ -440,8 +439,6 @@ there.")
440 (set-buffer nntp-server-buffer) 439 (set-buffer nntp-server-buffer)
441 (erase-buffer) 440 (erase-buffer)
442 (condition-case () 441 (condition-case ()
443 ;; 1997/8/14 by MORIOKA Tomohiko
444 ;; for Win32
445 (let ((nnheader-file-coding-system nnspool-file-coding-system)) 442 (let ((nnheader-file-coding-system nnspool-file-coding-system))
446 (nnheader-insert-file-contents file) 443 (nnheader-insert-file-contents file)
447 t) 444 t)
diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el
index 0812be9917d..a653c5d65ec 100644
--- a/lisp/gnus/nntp.el
+++ b/lisp/gnus/nntp.el
@@ -1,7 +1,7 @@
1;;; nntp.el --- nntp access for Gnus 1;;; nntp.el --- nntp access for Gnus Copyright (C) 1987-90,92-97 Free
2;;; Copyright (C) 1987,88,89,90,92,93,94,95,96,97 Free Software Foundation, Inc. 2;;; Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: news 5;; Keywords: news
6 6
7;; This file is part of GNU Emacs. 7;; This file is part of GNU Emacs.
@@ -45,13 +45,11 @@
45(defvoo nntp-server-opened-hook '(nntp-send-mode-reader) 45(defvoo nntp-server-opened-hook '(nntp-send-mode-reader)
46 "*Hook used for sending commands to the server at startup. 46 "*Hook used for sending commands to the server at startup.
47The default value is `nntp-send-mode-reader', which makes an innd 47The default value is `nntp-send-mode-reader', which makes an innd
48server spawn an nnrpd server. Another useful function to put in this 48server spawn an nnrpd server.")
49hook might be `nntp-send-authinfo', which will prompt for a password
50to allow posting from the server. Note that this is only necessary to
51do on servers that use strict access control.")
52 49
53(defvoo nntp-authinfo-function 'nntp-send-authinfo 50(defvoo nntp-authinfo-function 'nntp-send-authinfo
54 "Function used to send AUTHINFO to the server.") 51 "Function used to send AUTHINFO to the server.
52It is called with no parameters.")
55 53
56(defvoo nntp-server-action-alist 54(defvoo nntp-server-action-alist
57 '(("nntpd 1\\.5\\.11t" 55 '(("nntpd 1\\.5\\.11t"
@@ -79,8 +77,12 @@ the NNTP server available there (see nntp-rlogin-parameters) and
79`nntp-open-telnet' which telnets to a remote system, logs in and does 77`nntp-open-telnet' which telnets to a remote system, logs in and does
80the same.") 78the same.")
81 79
80(defvoo nntp-rlogin-program "rsh"
81 "*Program used to log in on remote machines.
82The default is \"rsh\", but \"ssh\" is a popular alternative.")
83
82(defvoo nntp-rlogin-parameters '("telnet" "-8" "${NNTPSERVER:=news}" "nntp") 84(defvoo nntp-rlogin-parameters '("telnet" "-8" "${NNTPSERVER:=news}" "nntp")
83 "*Parameters to `nntp-open-login'. 85 "*Parameters to `nntp-open-rlogin'.
84That function may be used as `nntp-open-connection-function'. In that 86That function may be used as `nntp-open-connection-function'. In that
85case, this list will be used as the parameter list given to rsh.") 87case, this list will be used as the parameter list given to rsh.")
86 88
@@ -99,6 +101,12 @@ via telnet.")
99(defvoo nntp-telnet-passwd nil 101(defvoo nntp-telnet-passwd nil
100 "Password to use to log in via telnet with.") 102 "Password to use to log in via telnet with.")
101 103
104(defvoo nntp-open-telnet-envuser nil
105 "*If non-nil, telnet session (client and server both) will support the ENVIRON option and not prompt for login name.")
106
107(defvoo nntp-telnet-shell-prompt "bash\\|\$ *\r?$\\|> *\r?"
108 "*Regular expression to match the shell prompt on the remote machine.")
109
102(defvoo nntp-telnet-command "telnet" 110(defvoo nntp-telnet-command "telnet"
103 "Command used to start telnet.") 111 "Command used to start telnet.")
104 112
@@ -134,21 +142,41 @@ by one.")
134If the gap between two consecutive articles is bigger than this 142If the gap between two consecutive articles is bigger than this
135variable, split the XOVER request into two requests.") 143variable, split the XOVER request into two requests.")
136 144
137(defvoo nntp-connection-timeout nil
138 "*Number of seconds to wait before an nntp connection times out.
139If this variable is nil, which is the default, no timers are set.")
140
141(defvoo nntp-prepare-server-hook nil 145(defvoo nntp-prepare-server-hook nil
142 "*Hook run before a server is opened. 146 "*Hook run before a server is opened.
143If can be used to set up a server remotely, for instance. Say you 147If can be used to set up a server remotely, for instance. Say you
144have an account at the machine \"other.machine\". This machine has 148have an account at the machine \"other.machine\". This machine has
145access to an NNTP server that you can't access locally. You could 149access to an NNTP server that you can't access locally. You could
146then use this hook to rsh to the remote machine and start a proxy NNTP 150then use this hook to rsh to the remote machine and start a proxy NNTP
147server there that you can connect to. See also `nntp-open-connection-function'") 151server there that you can connect to. See also
152`nntp-open-connection-function'")
148 153
149(defvoo nntp-warn-about-losing-connection t 154(defvoo nntp-warn-about-losing-connection t
150 "*If non-nil, beep when a server closes connection.") 155 "*If non-nil, beep when a server closes connection.")
151 156
157(defvoo nntp-coding-system-for-read 'binary
158 "*Coding system to read from NNTP.")
159
160(defvoo nntp-coding-system-for-write 'binary
161 "*Coding system to write to NNTP.")
162
163(defcustom nntp-authinfo-file "~/.authinfo"
164 ".netrc-like file that holds nntp authinfo passwords."
165 :type
166 '(choice file
167 (repeat :tag "Entries"
168 :menu-tag "Inline"
169 (list :format "%v"
170 :value ("" ("login" . "") ("password" . ""))
171 (string :tag "Host")
172 (checklist :inline t
173 (cons :format "%v"
174 (const :format "" "login")
175 (string :format "Login: %v"))
176 (cons :format "%v"
177 (const :format "" "password")
178 (string :format "Password: %v")))))))
179
152;; 1997/5/4 by MORIOKA Tomohiko <morioka@jaist.ac.jp> 180;; 1997/5/4 by MORIOKA Tomohiko <morioka@jaist.ac.jp>
153(defvoo nntp-coding-system-for-read 'binary 181(defvoo nntp-coding-system-for-read 'binary
154 "*Coding system to read from NNTP.") 182 "*Coding system to read from NNTP.")
@@ -158,8 +186,15 @@ server there that you can connect to. See also `nntp-open-connection-function'"
158 186
159 187
160 188
189(defvoo nntp-connection-timeout nil
190 "*Number of seconds to wait before an nntp connection times out.
191If this variable is nil, which is the default, no timers are set.")
192
161;;; Internal variables. 193;;; Internal variables.
162 194
195(defvar nntp-record-commands nil
196 "*If non-nil, nntp will record all commands in the \"*nntp-log*\" buffer.")
197
163(defvar nntp-have-messaged nil) 198(defvar nntp-have-messaged nil)
164 199
165(defvar nntp-process-wait-for nil) 200(defvar nntp-process-wait-for nil)
@@ -168,6 +203,10 @@ server there that you can connect to. See also `nntp-open-connection-function'"
168(defvar nntp-process-decode nil) 203(defvar nntp-process-decode nil)
169(defvar nntp-process-start-point nil) 204(defvar nntp-process-start-point nil)
170(defvar nntp-inside-change-function nil) 205(defvar nntp-inside-change-function nil)
206(defvoo nntp-last-command-time nil)
207(defvoo nntp-last-command nil)
208(defvoo nntp-authinfo-password nil)
209(defvoo nntp-authinfo-user nil)
171 210
172(defvar nntp-connection-list nil) 211(defvar nntp-connection-list nil)
173 212
@@ -182,7 +221,8 @@ server there that you can connect to. See also `nntp-open-connection-function'"
182(defvoo nntp-server-list-active-group 'try) 221(defvoo nntp-server-list-active-group 'try)
183 222
184(eval-and-compile 223(eval-and-compile
185 (autoload 'nnmail-read-passwd "nnmail")) 224 (autoload 'nnmail-read-passwd "nnmail")
225 (autoload 'open-ssl-stream "ssl"))
186 226
187 227
188 228
@@ -190,32 +230,53 @@ server there that you can connect to. See also `nntp-open-connection-function'"
190 230
191(defsubst nntp-send-string (process string) 231(defsubst nntp-send-string (process string)
192 "Send STRING to PROCESS." 232 "Send STRING to PROCESS."
233 ;; We need to store the time to provide timeouts, and
234 ;; to store the command so the we can replay the command
235 ;; if the server gives us an AUTHINFO challenge.
236 (setq nntp-last-command-time (current-time)
237 nntp-last-command string)
238 (when nntp-record-commands
239 (nntp-record-command string))
193 (process-send-string process (concat string nntp-end-of-line))) 240 (process-send-string process (concat string nntp-end-of-line)))
194 241
242(defun nntp-record-command (string)
243 "Record the command STRING."
244 (save-excursion
245 (set-buffer (get-buffer-create "*nntp-log*"))
246 (goto-char (point-max))
247 (let ((time (current-time)))
248 (insert (format-time-string "%Y%m%dT%H%M%S" time)
249 "." (format "%03d" (/ (nth 2 time) 1000))
250 " " nntp-address " " string "\n"))))
251
195(defsubst nntp-wait-for (process wait-for buffer &optional decode discard) 252(defsubst nntp-wait-for (process wait-for buffer &optional decode discard)
196 "Wait for WAIT-FOR to arrive from PROCESS." 253 "Wait for WAIT-FOR to arrive from PROCESS."
197 (save-excursion 254 (save-excursion
198 (set-buffer (process-buffer process)) 255 (set-buffer (process-buffer process))
199 (goto-char (point-min)) 256 (goto-char (point-min))
200 (while (or (not (memq (char-after (point)) '(?2 ?3 ?4 ?5))) 257 (while (and (or (not (memq (char-after (point)) '(?2 ?3 ?4 ?5)))
201 (looking-at "480")) 258 (looking-at "480"))
259 (memq (process-status process) '(open run)))
202 (when (looking-at "480") 260 (when (looking-at "480")
203 (erase-buffer) 261 (nntp-handle-authinfo process))
204 (funcall nntp-authinfo-function))
205 (nntp-accept-process-output process) 262 (nntp-accept-process-output process)
206 (goto-char (point-min))) 263 (goto-char (point-min)))
207 (prog1 264 (prog1
208 (if (looking-at "[45]") 265 (cond
209 (progn 266 ((looking-at "[45]")
210 (nntp-snarf-error-message) 267 (progn
211 nil) 268 (nntp-snarf-error-message)
269 nil))
270 ((not (memq (process-status process) '(open run)))
271 (nnheader-report 'nntp "Server closed connection"))
272 (t
212 (goto-char (point-max)) 273 (goto-char (point-max))
213 (let ((limit (point-min))) 274 (let ((limit (point-min)))
214 (while (not (re-search-backward wait-for limit t)) 275 (while (not (re-search-backward wait-for limit t))
276 (nntp-accept-process-output process)
215 ;; We assume that whatever we wait for is less than 1000 277 ;; We assume that whatever we wait for is less than 1000
216 ;; characters long. 278 ;; characters long.
217 (setq limit (max (- (point-max) 1000) (point-min))) 279 (setq limit (max (- (point-max) 1000) (point-min)))
218 (nntp-accept-process-output process)
219 (goto-char (point-max)))) 280 (goto-char (point-max))))
220 (nntp-decode-text (not decode)) 281 (nntp-decode-text (not decode))
221 (unless discard 282 (unless discard
@@ -226,8 +287,8 @@ server there that you can connect to. See also `nntp-open-connection-function'"
226 ;; Nix out "nntp reading...." message. 287 ;; Nix out "nntp reading...." message.
227 (when nntp-have-messaged 288 (when nntp-have-messaged
228 (setq nntp-have-messaged nil) 289 (setq nntp-have-messaged nil)
229 (message "")) 290 (nnheader-message 5 ""))
230 t))) 291 t))))
231 (unless discard 292 (unless discard
232 (erase-buffer))))) 293 (erase-buffer)))))
233 294
@@ -259,7 +320,7 @@ server there that you can connect to. See also `nntp-open-connection-function'"
259 (process-buffer process)))) 320 (process-buffer process))))
260 321
261(defsubst nntp-retrieve-data (command address port buffer 322(defsubst nntp-retrieve-data (command address port buffer
262 &optional wait-for callback decode) 323 &optional wait-for callback decode)
263 "Use COMMAND to retrieve data into BUFFER from PORT on ADDRESS." 324 "Use COMMAND to retrieve data into BUFFER from PORT on ADDRESS."
264 (let ((process (or (nntp-find-connection buffer) 325 (let ((process (or (nntp-find-connection buffer)
265 (nntp-open-connection buffer)))) 326 (nntp-open-connection buffer))))
@@ -342,6 +403,24 @@ server there that you can connect to. See also `nntp-open-connection-function'"
342 403
343(nnoo-define-basics nntp) 404(nnoo-define-basics nntp)
344 405
406(defsubst nntp-next-result-arrived-p ()
407 (cond
408 ;; A result that starts with a 2xx code is terminated by
409 ;; a line with only a "." on it.
410 ((eq (following-char) ?2)
411 (if (re-search-forward "\n\\.\r?\n" nil t)
412 t
413 nil))
414 ;; A result that starts with a 3xx or 4xx code is terminated
415 ;; by a newline.
416 ((looking-at "[34]")
417 (if (search-forward "\n" nil t)
418 t
419 nil))
420 ;; No result here.
421 (t
422 nil)))
423
345(deffoo nntp-retrieve-headers (articles &optional group server fetch-old) 424(deffoo nntp-retrieve-headers (articles &optional group server fetch-old)
346 "Retrieve the headers of ARTICLES." 425 "Retrieve the headers of ARTICLES."
347 (nntp-possibly-change-group group server) 426 (nntp-possibly-change-group group server)
@@ -360,49 +439,39 @@ server there that you can connect to. See also `nntp-open-connection-function'"
360 (received 0) 439 (received 0)
361 (last-point (point-min)) 440 (last-point (point-min))
362 (buf (nntp-find-connection-buffer nntp-server-buffer)) 441 (buf (nntp-find-connection-buffer nntp-server-buffer))
363 (nntp-inhibit-erase t)) 442 (nntp-inhibit-erase t)
364 ;; Send HEAD command. 443 article)
365 (while articles 444 ;; Send HEAD commands.
366 (nntp-send-command 445 (while (setq article (pop articles))
367 nil 446 (nntp-send-command
368 "HEAD" (if (numberp (car articles)) 447 nil
369 (int-to-string (car articles)) 448 "HEAD" (if (numberp article)
370 ;; `articles' is either a list of article numbers 449 (int-to-string article)
371 ;; or a list of article IDs. 450 ;; `articles' is either a list of article numbers
372 (car articles))) 451 ;; or a list of article IDs.
373 (setq articles (cdr articles) 452 article))
374 count (1+ count)) 453 (incf count)
375 ;; Every 400 header requests we have to read the stream in 454 ;; Every 400 requests we have to read the stream in
376 ;; order to avoid deadlocks. 455 ;; order to avoid deadlocks.
377 (when (or (null articles) ;All requests have been sent. 456 (when (or (null articles) ;All requests have been sent.
378 (zerop (% count nntp-maximum-request))) 457 (zerop (% count nntp-maximum-request)))
379 (nntp-accept-response) 458 (nntp-accept-response)
380 (while (progn
381 (progn
382 (set-buffer buf)
383 (goto-char last-point))
384 ;; Count replies.
385 (while (re-search-forward "^[0-9]" nil t)
386 (incf received))
387 (setq last-point (point))
388 (< received count))
389 ;; If number of headers is greater than 100, give
390 ;; informative messages.
391 (and (numberp nntp-large-newsgroup)
392 (> number nntp-large-newsgroup)
393 (zerop (% received 20))
394 (nnheader-message 6 "NNTP: Receiving headers... %d%%"
395 (/ (* received 100) number)))
396 (nntp-accept-response))))
397 ;; Wait for text of last command.
398 (goto-char (point-max))
399 (re-search-backward "^[0-9]" nil t)
400 (when (looking-at "^[23]")
401 (while (progn 459 (while (progn
402 (goto-char (point-max)) 460 (set-buffer buf)
403 (forward-line -1) 461 (goto-char last-point)
404 (not (looking-at "^\\.\r?\n"))) 462 ;; Count replies.
405 (nntp-accept-response))) 463 (while (nntp-next-result-arrived-p)
464 (setq last-point (point))
465 (incf received))
466 (< received count))
467 ;; If number of headers is greater than 100, give
468 ;; informative messages.
469 (and (numberp nntp-large-newsgroup)
470 (> number nntp-large-newsgroup)
471 (zerop (% received 20))
472 (nnheader-message 6 "NNTP: Receiving headers... %d%%"
473 (/ (* received 100) number)))
474 (nntp-accept-response))))
406 (and (numberp nntp-large-newsgroup) 475 (and (numberp nntp-large-newsgroup)
407 (> number nntp-large-newsgroup) 476 (> number nntp-large-newsgroup)
408 (nnheader-message 6 "NNTP: Receiving headers...done")) 477 (nnheader-message 6 "NNTP: Receiving headers...done"))
@@ -487,10 +556,10 @@ server there that you can connect to. See also `nntp-open-connection-function'"
487 (nntp-inhibit-erase t) 556 (nntp-inhibit-erase t)
488 (map (apply 'vector articles)) 557 (map (apply 'vector articles))
489 (point 1) 558 (point 1)
490 article alist) 559 article)
491 (set-buffer buf) 560 (set-buffer buf)
492 (erase-buffer) 561 (erase-buffer)
493 ;; Send HEAD command. 562 ;; Send ARTICLE command.
494 (while (setq article (pop articles)) 563 (while (setq article (pop articles))
495 (nntp-send-command 564 (nntp-send-command
496 nil 565 nil
@@ -506,14 +575,13 @@ server there that you can connect to. See also `nntp-open-connection-function'"
506 (zerop (% count nntp-maximum-request))) 575 (zerop (% count nntp-maximum-request)))
507 (nntp-accept-response) 576 (nntp-accept-response)
508 (while (progn 577 (while (progn
509 (progn 578 (set-buffer buf)
510 (set-buffer buf) 579 (goto-char last-point)
511 (goto-char last-point))
512 ;; Count replies. 580 ;; Count replies.
513 (while (nntp-next-result-arrived-p) 581 (while (nntp-next-result-arrived-p)
514 (aset map received (cons (aref map received) (point))) 582 (aset map received (cons (aref map received) (point)))
583 (setq last-point (point))
515 (incf received)) 584 (incf received))
516 (setq last-point (point))
517 (< received count)) 585 (< received count))
518 ;; If number of headers is greater than 100, give 586 ;; If number of headers is greater than 100, give
519 ;; informative messages. 587 ;; informative messages.
@@ -525,12 +593,13 @@ server there that you can connect to. See also `nntp-open-connection-function'"
525 (nntp-accept-response)))) 593 (nntp-accept-response))))
526 (and (numberp nntp-large-newsgroup) 594 (and (numberp nntp-large-newsgroup)
527 (> number nntp-large-newsgroup) 595 (> number nntp-large-newsgroup)
528 (nnheader-message 6 "NNTP: Receiving headers...done")) 596 (nnheader-message 6 "NNTP: Receiving articles...done"))
529 597
530 ;; Now we have all the responses. We go through the results, 598 ;; Now we have all the responses. We go through the results,
531 ;; washes it and copies it over to the server buffer. 599 ;; wash it and copy it over to the server buffer.
532 (set-buffer nntp-server-buffer) 600 (set-buffer nntp-server-buffer)
533 (erase-buffer) 601 (erase-buffer)
602 (setq last-point (point-min))
534 (mapcar 603 (mapcar
535 (lambda (entry) 604 (lambda (entry)
536 (narrow-to-region 605 (narrow-to-region
@@ -538,25 +607,12 @@ server there that you can connect to. See also `nntp-open-connection-function'"
538 (progn 607 (progn
539 (insert-buffer-substring buf last-point (cdr entry)) 608 (insert-buffer-substring buf last-point (cdr entry))
540 (point-max))) 609 (point-max)))
610 (setq last-point (cdr entry))
541 (nntp-decode-text) 611 (nntp-decode-text)
542 (widen) 612 (widen)
543 (cons (car entry) point)) 613 (cons (car entry) point))
544 map)))) 614 map))))
545 615
546(defun nntp-next-result-arrived-p ()
547 (let ((point (point)))
548 (cond
549 ((looking-at "2")
550 (if (re-search-forward "\n.\r?\n" nil t)
551 t
552 (goto-char point)
553 nil))
554 ((looking-at "[34]")
555 (forward-line 1)
556 t)
557 (t
558 nil))))
559
560(defun nntp-try-list-active (group) 616(defun nntp-try-list-active (group)
561 (nntp-list-active-group group) 617 (nntp-list-active-group group)
562 (save-excursion 618 (save-excursion
@@ -603,7 +659,7 @@ server there that you can connect to. See also `nntp-open-connection-function'"
603 659
604(deffoo nntp-request-group (group &optional server dont-check) 660(deffoo nntp-request-group (group &optional server dont-check)
605 (nntp-possibly-change-group nil server) 661 (nntp-possibly-change-group nil server)
606 (when (nntp-send-command "^2.*\n" "GROUP" group) 662 (when (nntp-send-command "^[245].*\n" "GROUP" group)
607 (let ((entry (nntp-find-connection-entry nntp-server-buffer))) 663 (let ((entry (nntp-find-connection-entry nntp-server-buffer)))
608 (setcar (cddr entry) group)))) 664 (setcar (cddr entry) group))))
609 665
@@ -633,22 +689,34 @@ server there that you can connect to. See also `nntp-open-connection-function'"
633 689
634(deffoo nntp-close-server (&optional server) 690(deffoo nntp-close-server (&optional server)
635 (nntp-possibly-change-group nil server t) 691 (nntp-possibly-change-group nil server t)
636 (let (process) 692 (let ((process (nntp-find-connection nntp-server-buffer)))
637 (while (setq process (car (pop nntp-connection-alist))) 693 (while process
638 (when (memq (process-status process) '(open run)) 694 (when (memq (process-status process) '(open run))
639 (set-process-sentinel process nil) 695 (ignore-errors
640 (nntp-send-string process "QUIT")) 696 (nntp-send-string process "QUIT")
697 (unless (eq nntp-open-connection-function 'nntp-open-network-stream)
698 ;; Ok, this is evil, but when using telnet and stuff
699 ;; as the connection method, it's important that the
700 ;; QUIT command actually is sent out before we kill
701 ;; the process.
702 (sleep-for 1))))
641 (when (buffer-name (process-buffer process)) 703 (when (buffer-name (process-buffer process))
642 (kill-buffer (process-buffer process)))) 704 (kill-buffer (process-buffer process)))
705 (setq process (car (pop nntp-connection-alist))))
643 (nnoo-close-server 'nntp))) 706 (nnoo-close-server 'nntp)))
644 707
645(deffoo nntp-request-close () 708(deffoo nntp-request-close ()
646 (let (process) 709 (let (process)
647 (while (setq process (pop nntp-connection-list)) 710 (while (setq process (pop nntp-connection-list))
648 (when (memq (process-status process) '(open run)) 711 (when (memq (process-status process) '(open run))
649 (set-process-sentinel process nil)
650 (ignore-errors 712 (ignore-errors
651 (nntp-send-string process "QUIT"))) 713 (nntp-send-string process "QUIT")
714 (unless (eq nntp-open-connection-function 'nntp-open-network-stream)
715 ;; Ok, this is evil, but when using telnet and stuff
716 ;; as the connection method, it's important that the
717 ;; QUIT command actually is sent out before we kill
718 ;; the process.
719 (sleep-for 1))))
652 (when (buffer-name (process-buffer process)) 720 (when (buffer-name (process-buffer process))
653 (kill-buffer (process-buffer process)))))) 721 (kill-buffer (process-buffer process))))))
654 722
@@ -664,16 +732,11 @@ server there that you can connect to. See also `nntp-open-connection-function'"
664 (nntp-possibly-change-group nil server) 732 (nntp-possibly-change-group nil server)
665 (save-excursion 733 (save-excursion
666 (set-buffer nntp-server-buffer) 734 (set-buffer nntp-server-buffer)
667 (let* ((date (timezone-parse-date date)) 735 (prog1
668 (time-string 736 (nntp-send-command
669 (format "%s%02d%02d %s%s%s" 737 "^\\.\r?\n" "NEWGROUPS"
670 (substring (aref date 0) 2) (string-to-int (aref date 1)) 738 (format-time-string "%y%m%d %H%M%S" (nnmail-date-to-time date)))
671 (string-to-int (aref date 2)) (substring (aref date 3) 0 2) 739 (nntp-decode-text))))
672 (substring
673 (aref date 3) 3 5) (substring (aref date 3) 6 8))))
674 (prog1
675 (nntp-send-command "^\\.\r?\n" "NEWGROUPS" time-string)
676 (nntp-decode-text)))))
677 740
678(deffoo nntp-request-post (&optional server) 741(deffoo nntp-request-post (&optional server)
679 (nntp-possibly-change-group nil server) 742 (nntp-possibly-change-group nil server)
@@ -695,40 +758,72 @@ It will make innd servers spawn an nnrpd process to allow actual article
695reading." 758reading."
696 (nntp-send-command "^.*\r?\n" "MODE READER")) 759 (nntp-send-command "^.*\r?\n" "MODE READER"))
697 760
698(defun nntp-send-nosy-authinfo () 761(defun nntp-send-authinfo (&optional send-if-force)
699 "Send the AUTHINFO to the nntp server.
700This function is supposed to be called from `nntp-server-opened-hook'.
701It will prompt for a password."
702 (nntp-send-command
703 "^.*\r?\n" "AUTHINFO USER"
704 (read-string (format "NNTP (%s) user name: " nntp-address)))
705 (nntp-send-command
706 "^.*\r?\n" "AUTHINFO PASS"
707 (nnmail-read-passwd "NNTP (%s) password: " nntp-address)))
708
709(defun nntp-send-authinfo ()
710 "Send the AUTHINFO to the nntp server. 762 "Send the AUTHINFO to the nntp server.
711This function is supposed to be called from `nntp-server-opened-hook'. 763It will look in the \"~/.authinfo\" file for matching entries. If
712It will prompt for a password." 764nothing suitable is found there, it will prompt for a user name
713 (nntp-send-command "^.*\r?\n" "AUTHINFO USER" (user-login-name)) 765and a password.
714 (nntp-send-command 766
715 "^.*\r?\n" "AUTHINFO PASS" 767If SEND-IF-FORCE, only send authinfo to the server if the
716 (nnmail-read-passwd (format "NNTP (%s) password: " nntp-address)))) 768.authinfo file has the FORCE token."
769 (let* ((list (gnus-parse-netrc nntp-authinfo-file))
770 (alist (gnus-netrc-machine list nntp-address))
771 (force (gnus-netrc-get alist "force"))
772 (user (or (gnus-netrc-get alist "login") nntp-authinfo-user))
773 (passwd (gnus-netrc-get alist "password")))
774 (when (or (not send-if-force)
775 force)
776 (unless user
777 (setq user (read-string (format "NNTP (%s) user name: " nntp-address))
778 nntp-authinfo-user user))
779 (unless (member user '(nil ""))
780 (nntp-send-command "^3.*\r?\n" "AUTHINFO USER" user)
781 (when t ;???Should check if AUTHINFO succeeded
782 (nntp-send-command
783 "^2.*\r?\n" "AUTHINFO PASS"
784 (or passwd
785 nntp-authinfo-password
786 (setq nntp-authinfo-password
787 (nnmail-read-passwd (format "NNTP (%s@%s) password: "
788 user nntp-address))))))))))
789
790(defun nntp-send-nosy-authinfo ()
791 "Send the AUTHINFO to the nntp server."
792 (let ((user (read-string (format "NNTP (%s) user name: " nntp-address))))
793 (unless (member user '(nil ""))
794 (nntp-send-command "^3.*\r?\n" "AUTHINFO USER" user)
795 (when t ;???Should check if AUTHINFO succeeded
796 (nntp-send-command "^2.*\r?\n" "AUTHINFO PASS"
797 (nnmail-read-passwd "NNTP (%s@%s) password: "
798 user nntp-address))))))
717 799
718(defun nntp-send-authinfo-from-file () 800(defun nntp-send-authinfo-from-file ()
719 "Send the AUTHINFO to the nntp server. 801 "Send the AUTHINFO to the nntp server.
720This function is supposed to be called from `nntp-server-opened-hook'." 802
803The authinfo login name is taken from the user's login name and the
804password contained in '~/.nntp-authinfo'."
721 (when (file-exists-p "~/.nntp-authinfo") 805 (when (file-exists-p "~/.nntp-authinfo")
722 (nnheader-temp-write nil 806 (nnheader-temp-write nil
723 (insert-file-contents "~/.nntp-authinfo") 807 (insert-file-contents "~/.nntp-authinfo")
724 (goto-char (point-min)) 808 (goto-char (point-min))
725 (nntp-send-command "^.*\r?\n" "AUTHINFO USER" (user-login-name)) 809 (nntp-send-command "^3.*\r?\n" "AUTHINFO USER" (user-login-name))
726 (nntp-send-command 810 (nntp-send-command
727 "^.*\r?\n" "AUTHINFO PASS" 811 "^2.*\r?\n" "AUTHINFO PASS"
728 (buffer-substring (point) (progn (end-of-line) (point))))))) 812 (buffer-substring (point) (progn (end-of-line) (point)))))))
729 813
730;;; Internal functions. 814;;; Internal functions.
731 815
816(defun nntp-handle-authinfo (process)
817 "Take care of an authinfo response from the server."
818 (let ((last nntp-last-command))
819 (funcall nntp-authinfo-function)
820 ;; We have to re-send the function that was interrupted by
821 ;; the authinfo request.
822 (save-excursion
823 (set-buffer nntp-server-buffer)
824 (erase-buffer))
825 (nntp-send-string process last)))
826
732(defun nntp-make-process-buffer (buffer) 827(defun nntp-make-process-buffer (buffer)
733 "Create a new, fresh buffer usable for nntp process connections." 828 "Create a new, fresh buffer usable for nntp process connections."
734 (save-excursion 829 (save-excursion
@@ -736,7 +831,7 @@ This function is supposed to be called from `nntp-server-opened-hook'."
736 (generate-new-buffer 831 (generate-new-buffer
737 (format " *server %s %s %s*" 832 (format " *server %s %s %s*"
738 nntp-address nntp-port-number 833 nntp-address nntp-port-number
739 (buffer-name (get-buffer buffer))))) 834 (gnus-buffer-exists-p buffer))))
740 (buffer-disable-undo (current-buffer)) 835 (buffer-disable-undo (current-buffer))
741 (set (make-local-variable 'after-change-functions) nil) 836 (set (make-local-variable 'after-change-functions) nil)
742 (set (make-local-variable 'nntp-process-wait-for) nil) 837 (set (make-local-variable 'nntp-process-wait-for) nil)
@@ -750,15 +845,24 @@ This function is supposed to be called from `nntp-server-opened-hook'."
750 "Open a connection to PORT on ADDRESS delivering output to BUFFER." 845 "Open a connection to PORT on ADDRESS delivering output to BUFFER."
751 (run-hooks 'nntp-prepare-server-hook) 846 (run-hooks 'nntp-prepare-server-hook)
752 (let* ((pbuffer (nntp-make-process-buffer buffer)) 847 (let* ((pbuffer (nntp-make-process-buffer buffer))
848 (timer
849 (and nntp-connection-timeout
850 (nnheader-run-at-time
851 nntp-connection-timeout nil
852 `(lambda ()
853 (when (buffer-name ,pbuffer)
854 (kill-buffer ,pbuffer))))))
753 (process 855 (process
754 (condition-case () 856 (condition-case ()
755 ;; 1997/5/4 by MORIOKA Tomohiko <morioka@jaist.ac.jp>
756 (let ((coding-system-for-read nntp-coding-system-for-read) 857 (let ((coding-system-for-read nntp-coding-system-for-read)
757 (coding-system-for-write nntp-coding-system-for-write)) 858 (coding-system-for-write nntp-coding-system-for-write))
758 (funcall nntp-open-connection-function pbuffer)) 859 (funcall nntp-open-connection-function pbuffer))
759 (error nil) 860 (error nil)
760 (quit nil)))) 861 (quit nil))))
761 (when process 862 (when timer
863 (nnheader-cancel-timer timer))
864 (when (and (buffer-name pbuffer)
865 process)
762 (process-kill-without-query process) 866 (process-kill-without-query process)
763 (nntp-wait-for process "^.*\n" buffer nil t) 867 (nntp-wait-for process "^.*\n" buffer nil t)
764 (if (memq (process-status process) '(open run)) 868 (if (memq (process-status process) '(open run))
@@ -771,7 +875,8 @@ This function is supposed to be called from `nntp-server-opened-hook'."
771 (erase-buffer) 875 (erase-buffer)
772 (set-buffer nntp-server-buffer) 876 (set-buffer nntp-server-buffer)
773 (let ((nnheader-callback-function nil)) 877 (let ((nnheader-callback-function nil))
774 (run-hooks 'nntp-server-opened-hook)))) 878 (run-hooks 'nntp-server-opened-hook)
879 (nntp-send-authinfo t))))
775 (when (buffer-name (process-buffer process)) 880 (when (buffer-name (process-buffer process))
776 (kill-buffer (process-buffer process))) 881 (kill-buffer (process-buffer process)))
777 nil)))) 882 nil))))
@@ -779,6 +884,16 @@ This function is supposed to be called from `nntp-server-opened-hook'."
779(defun nntp-open-network-stream (buffer) 884(defun nntp-open-network-stream (buffer)
780 (open-network-stream "nntpd" buffer nntp-address nntp-port-number)) 885 (open-network-stream "nntpd" buffer nntp-address nntp-port-number))
781 886
887(defun nntp-open-ssl-stream (buffer)
888 (let* ((ssl-program-arguments '("-connect" (concat host ":" service)))
889 (proc (open-ssl-stream "nntpd" buffer nntp-address nntp-port-number)))
890 (save-excursion
891 (set-buffer buffer)
892 (nntp-wait-for-string "^\r*20[01]")
893 (beginning-of-line)
894 (delete-region (point-min) (point))
895 proc)))
896
782(defun nntp-read-server-type () 897(defun nntp-read-server-type ()
783 "Find out what the name of the server we have connected to is." 898 "Find out what the name of the server we have connected to is."
784 ;; Wait for the status string to arrive. 899 ;; Wait for the status string to arrive.
@@ -804,18 +919,18 @@ This function is supposed to be called from `nntp-server-opened-hook'."
804 (save-excursion 919 (save-excursion
805 (goto-char beg) 920 (goto-char beg)
806 (if (looking-at "480") 921 (if (looking-at "480")
807 (funcall nntp-authinfo-function) 922 (nntp-handle-authinfo nntp-process-to-buffer)
808 (nntp-snarf-error-message) 923 (nntp-snarf-error-message)
809 (funcall nntp-process-callback nil))) 924 (funcall nntp-process-callback nil)))
810 (goto-char end) 925 (goto-char end)
811 (when (and (> (point) nntp-process-start-point) 926 (when (and (> (point) nntp-process-start-point)
812 (re-search-backward nntp-process-wait-for 927 (re-search-backward nntp-process-wait-for
813 nntp-process-start-point t)) 928 nntp-process-start-point t))
814 (when (buffer-name (get-buffer nntp-process-to-buffer)) 929 (when (gnus-buffer-exists-p nntp-process-to-buffer)
815 (let ((cur (current-buffer)) 930 (let ((cur (current-buffer))
816 (start nntp-process-start-point)) 931 (start nntp-process-start-point))
817 (save-excursion 932 (save-excursion
818 (set-buffer (get-buffer nntp-process-to-buffer)) 933 (set-buffer nntp-process-to-buffer)
819 (goto-char (point-max)) 934 (goto-char (point-max))
820 (let ((b (point))) 935 (let ((b (point)))
821 (insert-buffer-substring cur start) 936 (insert-buffer-substring cur start)
@@ -1072,13 +1187,20 @@ This function is supposed to be called from `nntp-server-opened-hook'."
1072 (case-fold-search t)) 1187 (case-fold-search t))
1073 (when (memq (process-status proc) '(open run)) 1188 (when (memq (process-status proc) '(open run))
1074 (process-send-string proc "set escape \^X\n") 1189 (process-send-string proc "set escape \^X\n")
1075 (process-send-string proc (concat "open " nntp-address "\n")) 1190 (cond
1076 (nntp-wait-for-string "^\r*.?login:") 1191 ((and nntp-open-telnet-envuser nntp-telnet-user-name)
1077 (process-send-string 1192 (process-send-string proc (concat "open " "-l" nntp-telnet-user-name
1078 proc (concat 1193 nntp-address "\n")))
1079 (or nntp-telnet-user-name 1194 (t
1080 (setq nntp-telnet-user-name (read-string "login: "))) 1195 (process-send-string proc (concat "open " nntp-address "\n"))))
1081 "\n")) 1196 (cond
1197 ((not nntp-open-telnet-envuser)
1198 (nntp-wait-for-string "^\r*.?login:")
1199 (process-send-string
1200 proc (concat
1201 (or nntp-telnet-user-name
1202 (setq nntp-telnet-user-name (read-string "login: ")))
1203 "\n"))))
1082 (nntp-wait-for-string "^\r*.?password:") 1204 (nntp-wait-for-string "^\r*.?password:")
1083 (process-send-string 1205 (process-send-string
1084 proc (concat 1206 proc (concat
@@ -1087,10 +1209,10 @@ This function is supposed to be called from `nntp-server-opened-hook'."
1087 (nnmail-read-passwd "Password: "))) 1209 (nnmail-read-passwd "Password: ")))
1088 "\n")) 1210 "\n"))
1089 (erase-buffer) 1211 (erase-buffer)
1090 (nntp-wait-for-string "bash\\|\$ *\r?$\\|> *\r?") 1212 (nntp-wait-for-string nntp-telnet-shell-prompt)
1091 (process-send-string 1213 (process-send-string
1092 proc (concat (mapconcat 'identity nntp-telnet-parameters " ") "\n")) 1214 proc (concat (mapconcat 'identity nntp-telnet-parameters " ") "\n"))
1093 (nntp-wait-for-string "^\r*200") 1215 (nntp-wait-for-string "^\r*20[01]")
1094 (beginning-of-line) 1216 (beginning-of-line)
1095 (delete-region (point-min) (point)) 1217 (delete-region (point-min) (point))
1096 (process-send-string proc "\^]") 1218 (process-send-string proc "\^]")
@@ -1106,20 +1228,19 @@ This function is supposed to be called from `nntp-server-opened-hook'."
1106(defun nntp-open-rlogin (buffer) 1228(defun nntp-open-rlogin (buffer)
1107 "Open a connection to SERVER using rsh." 1229 "Open a connection to SERVER using rsh."
1108 (let ((proc (if nntp-rlogin-user-name 1230 (let ((proc (if nntp-rlogin-user-name
1109 (start-process 1231 (apply 'start-process
1110 "nntpd" buffer "rsh" 1232 "nntpd" buffer nntp-rlogin-program
1111 nntp-address "-l" nntp-rlogin-user-name 1233 nntp-address "-l" nntp-rlogin-user-name
1112 (mapconcat 'identity 1234 nntp-rlogin-parameters)
1113 nntp-rlogin-parameters " ")) 1235 (apply 'start-process
1114 (start-process 1236 "nntpd" buffer nntp-rlogin-program nntp-address
1115 "nntpd" buffer "rsh" nntp-address 1237 nntp-rlogin-parameters))))
1116 (mapconcat 'identity 1238 (save-excursion
1117 nntp-rlogin-parameters " "))))) 1239 (set-buffer buffer)
1118 (set-buffer buffer) 1240 (nntp-wait-for-string "^\r*20[01]")
1119 (nntp-wait-for-string "^\r*200") 1241 (beginning-of-line)
1120 (beginning-of-line) 1242 (delete-region (point-min) (point))
1121 (delete-region (point-min) (point)) 1243 proc)))
1122 proc))
1123 1244
1124(defun nntp-find-group-and-number () 1245(defun nntp-find-group-and-number ()
1125 (save-excursion 1246 (save-excursion
diff --git a/lisp/gnus/nnvirtual.el b/lisp/gnus/nnvirtual.el
index aece7417cbc..243717f5baf 100644
--- a/lisp/gnus/nnvirtual.el
+++ b/lisp/gnus/nnvirtual.el
@@ -1,8 +1,8 @@
1;;; nnvirtual.el --- virtual newsgroups access for Gnus 1;;; nnvirtual.el --- virtual newsgroups access for Gnus
2;; Copyright (C) 1994,95,96,97 Free Software Foundation, Inc. 2;; Copyright (C) 1994,95,96,97,98 Free Software Foundation, Inc.
3 3
4;; Author: David Moore <dmoore@ucsd.edu> 4;; Author: David Moore <dmoore@ucsd.edu>
5;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 5;; Lars Magne Ingebrigtsen <larsi@gnus.org>
6;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> 6;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
7;; Keywords: news 7;; Keywords: news
8 8
@@ -38,11 +38,12 @@
38(require 'gnus-util) 38(require 'gnus-util)
39(require 'gnus-start) 39(require 'gnus-start)
40(require 'gnus-sum) 40(require 'gnus-sum)
41(require 'gnus-msg)
41(eval-when-compile (require 'cl)) 42(eval-when-compile (require 'cl))
42 43
43(nnoo-declare nnvirtual) 44(nnoo-declare nnvirtual)
44 45
45(defvoo nnvirtual-always-rescan nil 46(defvoo nnvirtual-always-rescan t
46 "*If non-nil, always scan groups for unread articles when entering a group. 47 "*If non-nil, always scan groups for unread articles when entering a group.
47If this variable is nil (which is the default) and you read articles 48If this variable is nil (which is the default) and you read articles
48in a component group after the virtual group has been activated, the 49in a component group after the virtual group has been activated, the
@@ -258,10 +259,14 @@ to virtual article number.")
258 (setq nnvirtual-current-group nil) 259 (setq nnvirtual-current-group nil)
259 (nnheader-report 'nnvirtual "No component groups in %s" group)) 260 (nnheader-report 'nnvirtual "No component groups in %s" group))
260 (t 261 (t
262 (setq nnvirtual-current-group group)
261 (when (or (not dont-check) 263 (when (or (not dont-check)
262 nnvirtual-always-rescan) 264 nnvirtual-always-rescan)
263 (nnvirtual-create-mapping)) 265 (nnvirtual-create-mapping)
264 (setq nnvirtual-current-group group) 266 (when nnvirtual-always-rescan
267 (nnvirtual-request-update-info
268 (nnvirtual-current-group)
269 (gnus-get-info (nnvirtual-current-group)))))
265 (nnheader-insert "211 %d 1 %d %s\n" 270 (nnheader-insert "211 %d 1 %d %s\n"
266 nnvirtual-mapping-len nnvirtual-mapping-len group)))) 271 nnvirtual-mapping-len nnvirtual-mapping-len group))))
267 272
@@ -269,9 +274,12 @@ to virtual article number.")
269(deffoo nnvirtual-request-type (group &optional article) 274(deffoo nnvirtual-request-type (group &optional article)
270 (if (not article) 275 (if (not article)
271 'unknown 276 'unknown
272 (let ((mart (nnvirtual-map-article article))) 277 (if (numberp article)
273 (when mart 278 (let ((mart (nnvirtual-map-article article)))
274 (gnus-request-type (car mart) (cdr mart)))))) 279 (if mart
280 (gnus-request-type (car mart) (cdr mart))))
281 (gnus-request-type
282 nnvirtual-last-accessed-component-group nil))))
275 283
276(deffoo nnvirtual-request-update-mark (group article mark) 284(deffoo nnvirtual-request-update-mark (group article mark)
277 (let* ((nart (nnvirtual-map-article article)) 285 (let* ((nart (nnvirtual-map-article article))
@@ -342,6 +350,15 @@ to virtual article number.")
342 "Return the real group and article for virtual GROUP and ARTICLE." 350 "Return the real group and article for virtual GROUP and ARTICLE."
343 (nnvirtual-map-article article)) 351 (nnvirtual-map-article article))
344 352
353
354(deffoo nnvirtual-request-post (&optional server)
355 (if (not gnus-message-group-art)
356 (nnheader-report 'nnvirtual "Can't post to an nnvirtual group")
357 (let ((group (car (nnvirtual-find-group-art
358 (car gnus-message-group-art)
359 (cdr gnus-message-group-art)))))
360 (gnus-request-post (gnus-find-method-for-group group)))))
361
345 362
346;;; Internal functions. 363;;; Internal functions.
347 364
@@ -387,7 +404,7 @@ to virtual article number.")
387 (replace-match "" t t)) 404 (replace-match "" t t))
388 (goto-char (point-min)) 405 (goto-char (point-min))
389 (when (re-search-forward 406 (when (re-search-forward
390 (concat (gnus-group-real-name group) ":[0-9]+") 407 (concat (regexp-quote (gnus-group-real-name group)) ":[0-9]+")
391 nil t) 408 nil t)
392 (replace-match "" t t)) 409 (replace-match "" t t))
393 (unless (= (point) (point-max)) 410 (unless (= (point) (point-max))
@@ -560,27 +577,28 @@ If UPDATE-P is not nil, call gnus-group-update-group on the components."
560 577
561(defun nnvirtual-reverse-map-article (group article) 578(defun nnvirtual-reverse-map-article (group article)
562 "Return the virtual article number corresponding to the given component GROUP and ARTICLE." 579 "Return the virtual article number corresponding to the given component GROUP and ARTICLE."
563 (let ((table nnvirtual-mapping-table) 580 (when (numberp article)
564 (group-pos 0) 581 (let ((table nnvirtual-mapping-table)
565 entry) 582 (group-pos 0)
566 (while (not (string= group (car (aref nnvirtual-mapping-offsets 583 entry)
584 (while (not (string= group (car (aref nnvirtual-mapping-offsets
585 group-pos))))
586 (setq group-pos (1+ group-pos)))
587 (setq article (- article (cdr (aref nnvirtual-mapping-offsets
567 group-pos)))) 588 group-pos))))
568 (setq group-pos (1+ group-pos))) 589 (while (and table
569 (setq article (- article (cdr (aref nnvirtual-mapping-offsets 590 (> article (aref (car table) 0)))
570 group-pos)))) 591 (setq table (cdr table)))
571 (while (and table 592 (setq entry (car table))
572 (> article (aref (car table) 0))) 593 (when (and entry
573 (setq table (cdr table))) 594 (> article 0)
574 (setq entry (car table)) 595 (< group-pos (aref entry 2))) ; article not out of range below
575 (when (and entry 596 (+ (aref entry 4)
576 (> article 0) 597 group-pos
577 (< group-pos (aref entry 2))) ; article not out of range below 598 (* (- article (aref entry 1))
578 (+ (aref entry 4) 599 (aref entry 2))
579 group-pos 600 1))
580 (* (- article (aref entry 1)) 601 )))
581 (aref entry 2))
582 1))
583 ))
584 602
585 603
586(defsubst nnvirtual-reverse-map-sequence (group articles) 604(defsubst nnvirtual-reverse-map-sequence (group articles)
diff --git a/lisp/gnus/nnweb.el b/lisp/gnus/nnweb.el
index 2134577dcb8..c9d866a3a35 100644
--- a/lisp/gnus/nnweb.el
+++ b/lisp/gnus/nnweb.el
@@ -1,7 +1,7 @@
1;;; nnweb.el --- retrieving articles via web search engines 1;;; nnweb.el --- retrieving articles via web search engines
2;; Copyright (C) 1996,97 Free Software Foundation, Inc. 2;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: news 5;; Keywords: news
6 6
7;; This file is part of GNU Emacs. 7;; This file is part of GNU Emacs.
@@ -30,6 +30,8 @@
30 30
31(eval-when-compile (require 'cl)) 31(eval-when-compile (require 'cl))
32 32
33(eval-when-compile (require 'cl))
34
33(require 'nnoo) 35(require 'nnoo)
34(require 'message) 36(require 'message)
35(require 'gnus-util) 37(require 'gnus-util)
@@ -52,14 +54,22 @@
52 "Where nnweb will save its files.") 54 "Where nnweb will save its files.")
53 55
54(defvoo nnweb-type 'dejanews 56(defvoo nnweb-type 'dejanews
55 "What search engine type is being used.") 57 "What search engine type is being used.
58Valid types include `dejanews', `dejanewsold', `reference',
59and `altavista'.")
56 60
57(defvar nnweb-type-definition 61(defvoo nnweb-type-definition
58 '((dejanews 62 '((dejanews
59 (article . nnweb-dejanews-wash-article) 63 (article . nnweb-dejanews-wash-article)
60 (map . nnweb-dejanews-create-mapping) 64 (map . nnweb-dejanews-create-mapping)
61 (search . nnweb-dejanews-search) 65 (search . nnweb-dejanews-search)
62 (address . "http://xp9.dejanews.com/dnquery.xp") 66 (address . "http://x8.dejanews.com/dnquery.xp")
67 (identifier . nnweb-dejanews-identity))
68 (dejanewsold
69 (article . nnweb-dejanews-wash-article)
70 (map . nnweb-dejanews-create-mapping)
71 (search . nnweb-dejanewsold-search)
72 (address . "http://x8.dejanews.com/dnquery.xp")
63 (identifier . nnweb-dejanews-identity)) 73 (identifier . nnweb-dejanews-identity))
64 (reference 74 (reference
65 (article . nnweb-reference-wash-article) 75 (article . nnweb-reference-wash-article)
@@ -79,7 +89,7 @@
79(defvoo nnweb-search nil 89(defvoo nnweb-search nil
80 "Search string to feed to DejaNews.") 90 "Search string to feed to DejaNews.")
81 91
82(defvoo nnweb-max-hits 100 92(defvoo nnweb-max-hits 999
83 "Maximum number of hits to display.") 93 "Maximum number of hits to display.")
84 94
85(defvoo nnweb-ephemeral-p nil 95(defvoo nnweb-ephemeral-p nil
@@ -206,7 +216,7 @@
206 216
207(deffoo nnweb-request-delete-group (group &optional force server) 217(deffoo nnweb-request-delete-group (group &optional force server)
208 (nnweb-possibly-change-server group server) 218 (nnweb-possibly-change-server group server)
209 (gnus-delete-assoc group nnweb-group-alist) 219 (gnus-pull group nnweb-group-alist)
210 (gnus-delete-file (nnweb-overview-file group)) 220 (gnus-delete-file (nnweb-overview-file group))
211 t) 221 t)
212 222
@@ -379,49 +389,53 @@
379 (case-fold-search t) 389 (case-fold-search t)
380 (active (or (cadr (assoc nnweb-group nnweb-group-alist)) 390 (active (or (cadr (assoc nnweb-group nnweb-group-alist))
381 (cons 1 0))) 391 (cons 1 0)))
382 Subject Score Date Newsgroup Author 392 Subject (Score "0") Date Newsgroup Author
383 map url) 393 map url)
384 (while more 394 (while more
385 ;; Go through all the article hits on this page. 395 ;; Go through all the article hits on this page.
386 (goto-char (point-min)) 396 (goto-char (point-min))
387 (nnweb-decode-entities) 397 (nnweb-decode-entities)
388 (goto-char (point-min)) 398 (goto-char (point-min))
389 (while (re-search-forward "^ +[0-9]+\\." nil t) 399 (while (re-search-forward "^ <P>\n" nil t)
390 (narrow-to-region 400 (narrow-to-region
391 (point) 401 (point)
392 (cond ((re-search-forward "^ +[0-9]+\\." nil t) 402 (cond ((re-search-forward "^ <P>\n" nil t)
393 (match-beginning 0)) 403 (match-beginning 0))
394 ((search-forward "\n\n" nil t) 404 ((search-forward "\n\n" nil t)
395 (point)) 405 (point))
396 (t 406 (t
397 (point-max)))) 407 (point-max))))
398 (goto-char (point-min)) 408 (goto-char (point-min))
399 (when (looking-at ".*HREF=\"\\([^\"]+\\)\"") 409 (looking-at ".*HREF=\"\\([^\"]+\\)\"\\(.*\\)")
400 (setq url (match-string 1))) 410 (setq url (match-string 1))
401 (nnweb-remove-markup) 411 (let ((begin (point)))
402 (goto-char (point-min)) 412 (nnweb-remove-markup)
403 (while (search-forward "\t" nil t) 413 (goto-char begin)
404 (replace-match " ")) 414 (while (search-forward "\t" nil t)
405 (goto-char (point-min)) 415 (replace-match " "))
406 (while (re-search-forward "^ +\\([^:]+\\): +\\(.*\\)$" nil t) 416 (goto-char begin)
407 (set (intern (match-string 1)) (match-string 2))) 417 (end-of-line)
418 (setq Subject (buffer-substring begin (point)))
419 (if (re-search-forward
420 "^ Newsgroup: \\(.*\\)\n Posted on \\([0-9/]+\\) by \\(.*\\)$" nil t)
421 (setq Newsgroup (match-string 1)
422 Date (match-string 2)
423 Author (match-string 3))))
408 (widen) 424 (widen)
409 (when (string-match "#[0-9]+/[0-9]+ *$" Subject)
410 (setq Subject (substring Subject 0 (match-beginning 0))))
411 (incf i) 425 (incf i)
412 (unless (nnweb-get-hashtb url) 426 (unless (nnweb-get-hashtb url)
413 (push 427 (push
414 (list 428 (list
415 (incf (cdr active)) 429 (incf (cdr active))
416 (make-full-mail-header 430 (make-full-mail-header
417 (cdr active) (concat "(" Newsgroup ") " Subject) Author Date 431 (cdr active) Subject Author Date
418 (concat "<" (nnweb-identifier url) "@dejanews>") 432 (concat "<" (nnweb-identifier url) "@dejanews>")
419 nil 0 (string-to-int Score) url)) 433 nil 0 (string-to-int Score) url))
420 map) 434 map)
421 (nnweb-set-hashtb (cadar map) (car map)))) 435 (nnweb-set-hashtb (cadar map) (car map))))
422 ;; See whether there is a "Get next 20 hits" button here. 436 ;; See whether there is a "Get next 20 hits" button here.
423 (if (or (not (re-search-forward 437 (if (or (not (re-search-forward
424 "HREF=\"\\([^\"]+\\)\">Get next" nil t)) 438 "HREF=\"\\([^\"]+\\)\"[<>b]+Next result" nil t))
425 (>= i nnweb-max-hits)) 439 (>= i nnweb-max-hits))
426 (setq more nil) 440 (setq more nil)
427 ;; Yup -- fetch it. 441 ;; Yup -- fetch it.
@@ -430,8 +444,7 @@
430 (url-insert-file-contents more))) 444 (url-insert-file-contents more)))
431 ;; Return the articles in the right order. 445 ;; Return the articles in the right order.
432 (setq nnweb-articles 446 (setq nnweb-articles
433 (sort (nconc nnweb-articles map) 447 (sort (nconc nnweb-articles map) 'car-less-than-car))))))
434 (lambda (s1 s2) (< (car s1) (car s2)))))))))
435 448
436(defun nnweb-dejanews-wash-article () 449(defun nnweb-dejanews-wash-article ()
437 (let ((case-fold-search t)) 450 (let ((case-fold-search t))
@@ -461,9 +474,23 @@
461 ("defaultOp" . "AND") 474 ("defaultOp" . "AND")
462 ("svcclass" . "dncurrent") 475 ("svcclass" . "dncurrent")
463 ("maxhits" . "100") 476 ("maxhits" . "100")
464 ("format" . "verbose") 477 ("format" . "verbose2")
478 ("threaded" . "0")
479 ("showsort" . "date")
480 ("agesign" . "1")
481 ("ageweight" . "1")))
482 t)
483
484(defun nnweb-dejanewsold-search (search)
485 (nnweb-fetch-form
486 (nnweb-definition 'address)
487 `(("query" . ,search)
488 ("defaultOp" . "AND")
489 ("svcclass" . "dnold")
490 ("maxhits" . "100")
491 ("format" . "verbose2")
465 ("threaded" . "0") 492 ("threaded" . "0")
466 ("showsort" . "score") 493 ("showsort" . "date")
467 ("agesign" . "1") 494 ("agesign" . "1")
468 ("ageweight" . "1"))) 495 ("ageweight" . "1")))
469 t) 496 t)
@@ -530,8 +557,7 @@
530 (setq more nil)) 557 (setq more nil))
531 ;; Return the articles in the right order. 558 ;; Return the articles in the right order.
532 (setq nnweb-articles 559 (setq nnweb-articles
533 (sort (nconc nnweb-articles map) 560 (sort (nconc nnweb-articles map) 'car-less-than-car))))))
534 (lambda (s1 s2) (< (car s1) (car s2)))))))))
535 561
536(defun nnweb-reference-wash-article () 562(defun nnweb-reference-wash-article ()
537 (let ((case-fold-search t)) 563 (let ((case-fold-search t))
@@ -657,8 +683,7 @@
657 (setq more nil))) 683 (setq more nil)))
658 ;; Return the articles in the right order. 684 ;; Return the articles in the right order.
659 (setq nnweb-articles 685 (setq nnweb-articles
660 (sort (nconc nnweb-articles map) 686 (sort (nconc nnweb-articles map) 'car-less-than-car)))))))
661 (lambda (s1 s2) (< (car s1) (car s2))))))))))
662 687
663(defun nnweb-altavista-wash-article () 688(defun nnweb-altavista-wash-article ()
664 (goto-char (point-min)) 689 (goto-char (point-min))
diff --git a/lisp/gnus/pop3.el b/lisp/gnus/pop3.el
index ce1390f02e7..0b2243a1bf8 100644
--- a/lisp/gnus/pop3.el
+++ b/lisp/gnus/pop3.el
@@ -1,10 +1,10 @@
1;;; pop3.el --- Post Office Protocol (RFC 1460) interface 1;;; pop3.el --- Post Office Protocol (RFC 1460) interface
2 2
3;; Copyright (C) 1996,1997 Free Software Foundation, Inc. 3;; Copyright (C) 1996,1997,1998 Free Software Foundation, Inc.
4 4
5;; Author: Richard L. Pieri <ratinox@peorth.gweep.net> 5;; Author: Richard L. Pieri <ratinox@peorth.gweep.net>
6;; Keywords: mail, pop3 6;; Keywords: mail, pop3
7;; Version: 1.3g 7;; Version: 1.3m
8 8
9;; This file is part of GNU Emacs. 9;; This file is part of GNU Emacs.
10 10
@@ -37,9 +37,9 @@
37(require 'mail-utils) 37(require 'mail-utils)
38(provide 'pop3) 38(provide 'pop3)
39 39
40(defconst pop3-version "1.3g") 40(defconst pop3-version "1.3m")
41 41
42(defvar pop3-maildrop (or user-login-name (getenv "LOGNAME") (getenv "USER") nil) 42(defvar pop3-maildrop (or (user-login-name) (getenv "LOGNAME") (getenv "USER") nil)
43 "*POP3 maildrop.") 43 "*POP3 maildrop.")
44(defvar pop3-mailhost (or (getenv "MAILHOST") nil) 44(defvar pop3-mailhost (or (getenv "MAILHOST") nil)
45 "*POP3 mailhost.") 45 "*POP3 mailhost.")
@@ -72,9 +72,15 @@ Used for APOP authentication.")
72 (let* ((process (pop3-open-server pop3-mailhost pop3-port)) 72 (let* ((process (pop3-open-server pop3-mailhost pop3-port))
73 (crashbuf (get-buffer-create " *pop3-retr*")) 73 (crashbuf (get-buffer-create " *pop3-retr*"))
74 (n 1) 74 (n 1)
75 message-count) 75 message-count
76 (pop3-password pop3-password)
77 )
76 ;; for debugging only 78 ;; for debugging only
77 (if pop3-debug (switch-to-buffer (process-buffer process))) 79 (if pop3-debug (switch-to-buffer (process-buffer process)))
80 ;; query for password
81 (if (and pop3-password-required (not pop3-password))
82 (setq pop3-password
83 (pop3-read-passwd (format "Password for %s: " pop3-maildrop))))
78 (cond ((equal 'apop pop3-authentication-scheme) 84 (cond ((equal 'apop pop3-authentication-scheme)
79 (pop3-apop process pop3-maildrop)) 85 (pop3-apop process pop3-maildrop))
80 ((equal 'pass pop3-authentication-scheme) 86 ((equal 'pass pop3-authentication-scheme)
@@ -110,14 +116,16 @@ Returns the process associated with the connection."
110 (let ((process-buffer 116 (let ((process-buffer
111 (get-buffer-create (format "trace of POP session to %s" mailhost))) 117 (get-buffer-create (format "trace of POP session to %s" mailhost)))
112 (process) 118 (process)
113 (coding-system-for-read 'no-conversion) 119 (coding-system-for-read 'binary)
114 (coding-system-for-write 'no-conversion)) 120 (coding-system-for-write 'binary)
121 )
115 (save-excursion 122 (save-excursion
116 (set-buffer process-buffer) 123 (set-buffer process-buffer)
117 (erase-buffer)) 124 (erase-buffer)
125 (setq pop3-read-point (point-min))
126 )
118 (setq process 127 (setq process
119 (open-network-stream "POP" process-buffer mailhost port)) 128 (open-network-stream "POP" process-buffer mailhost port))
120 (setq pop3-read-point (point-min))
121 (let ((response (pop3-read-response process t))) 129 (let ((response (pop3-read-response process t)))
122 (setq pop3-timestamp 130 (setq pop3-timestamp
123 (substring response (or (string-match "<" response) 0) 131 (substring response (or (string-match "<" response) 0)
@@ -257,18 +265,27 @@ Return the response string if optional second argument is non-nil."
257 265
258(defun pop3-pass (process) 266(defun pop3-pass (process)
259 "Send authentication information to the server." 267 "Send authentication information to the server."
268 (pop3-send-command process (format "PASS %s" pop3-password))
269 (let ((response (pop3-read-response process t)))
270 (if (not (and response (string-match "+OK" response)))
271 (pop3-quit process))))
272
273(defun pop3-apop (process user)
274 "Send alternate authentication information to the server."
260 (let ((pass pop3-password)) 275 (let ((pass pop3-password))
261 (if (and pop3-password-required (not pass)) 276 (if (and pop3-password-required (not pass))
262 (setq pass 277 (setq pass
263 (pop3-read-passwd (format "Password for %s: " pop3-maildrop)))) 278 (pop3-read-passwd (format "Password for %s: " pop3-maildrop))))
264 (if pass 279 (if pass
265 (progn 280 (let ((hash (pop3-md5 (concat pop3-timestamp pass))))
266 (pop3-send-command process (format "PASS %s" pass)) 281 (pop3-send-command process (format "APOP %s %s" user hash))
267 (let ((response (pop3-read-response process t))) 282 (let ((response (pop3-read-response process t)))
268 (if (not (and response (string-match "+OK" response))) 283 (if (not (and response (string-match "+OK" response)))
269 (pop3-quit process))))) 284 (pop3-quit process)))))
270 )) 285 ))
271 286
287;; TRANSACTION STATE
288
272(defvar pop3-md5-program "md5" 289(defvar pop3-md5-program "md5"
273 "*Program to encode its input in MD5.") 290 "*Program to encode its input in MD5.")
274 291
@@ -283,22 +300,6 @@ Return the response string if optional second argument is non-nil."
283 ;; Don't return the newline that follows them! 300 ;; Don't return the newline that follows them!
284 (buffer-substring (point-min) (+ (point-min) 32)))) 301 (buffer-substring (point-min) (+ (point-min) 32))))
285 302
286(defun pop3-apop (process user)
287 "Send alternate authentication information to the server."
288 (let ((pass pop3-password))
289 (if (and pop3-password-required (not pass))
290 (setq pass
291 (pop3-read-passwd (format "Password for %s: " pop3-maildrop))))
292 (if pass
293 (let ((hash (pop3-md5 (concat pop3-timestamp pass))))
294 (pop3-send-command process (format "APOP %s %s" user hash))
295 (let ((response (pop3-read-response process t)))
296 (if (not (and response (string-match "+OK" response)))
297 (pop3-quit process)))))
298 ))
299
300;; TRANSACTION STATE
301
302(defun pop3-stat (process) 303(defun pop3-stat (process)
303 "Return the number of messages in the maildrop and the maildrop's size." 304 "Return the number of messages in the maildrop and the maildrop's size."
304 (pop3-send-command process "STAT") 305 (pop3-send-command process "STAT")
@@ -321,12 +322,17 @@ This function currently does nothing.")
321 (while (not (re-search-forward "^\\.\r\n" nil t)) 322 (while (not (re-search-forward "^\\.\r\n" nil t))
322 (accept-process-output process 3) 323 (accept-process-output process 3)
323 ;; bill@att.com ... to save wear and tear on the heap 324 ;; bill@att.com ... to save wear and tear on the heap
325 ;; uncommented because the condensed version below is a problem for
326 ;; some.
324 (if (> (buffer-size) 20000) (sleep-for 1)) 327 (if (> (buffer-size) 20000) (sleep-for 1))
325 (if (> (buffer-size) 50000) (sleep-for 1)) 328 (if (> (buffer-size) 50000) (sleep-for 1))
326 (if (> (buffer-size) 100000) (sleep-for 1)) 329 (if (> (buffer-size) 100000) (sleep-for 1))
327 (if (> (buffer-size) 200000) (sleep-for 1)) 330 (if (> (buffer-size) 200000) (sleep-for 1))
328 (if (> (buffer-size) 500000) (sleep-for 1)) 331 (if (> (buffer-size) 500000) (sleep-for 1))
329 ;; bill@att.com 332 ;; bill@att.com
333 ;; condensed into:
334 ;; (sometimes causes problems for really large messages.)
335; (if (> (buffer-size) 20000) (sleep-for (/ (buffer-size) 20000)))
330 (goto-char start)) 336 (goto-char start))
331 (setq pop3-read-point (point-marker)) 337 (setq pop3-read-point (point-marker))
332;; this code does not seem to work for some POP servers... 338;; this code does not seem to work for some POP servers...
diff --git a/lisp/gnus/score-mode.el b/lisp/gnus/score-mode.el
index fdb8d71b010..24c31f67242 100644
--- a/lisp/gnus/score-mode.el
+++ b/lisp/gnus/score-mode.el
@@ -1,7 +1,7 @@
1;;; score-mode.el --- mode for editing Gnus score files 1;;; score-mode.el --- mode for editing Gnus score files
2;; Copyright (C) 1996 Free Software Foundation, Inc. 2;; Copyright (C) 1996 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: news, mail 5;; Keywords: news, mail
6 6
7;; This file is part of GNU Emacs. 7;; This file is part of GNU Emacs.
@@ -45,6 +45,12 @@
45 (define-key gnus-score-mode-map "\C-c\C-d" 'gnus-score-edit-insert-date) 45 (define-key gnus-score-mode-map "\C-c\C-d" 'gnus-score-edit-insert-date)
46 (define-key gnus-score-mode-map "\C-c\C-p" 'gnus-score-pretty-print)) 46 (define-key gnus-score-mode-map "\C-c\C-p" 'gnus-score-pretty-print))
47 47
48(defvar score-mode-syntax-table
49 (let ((table (copy-syntax-table lisp-mode-syntax-table)))
50 (modify-syntax-entry ?| "w" table)
51 table)
52 "Syntax table used in score-mode buffers.")
53
48;;;###autoload 54;;;###autoload
49(defun gnus-score-mode () 55(defun gnus-score-mode ()
50 "Mode for editing Gnus score files. 56 "Mode for editing Gnus score files.
@@ -55,7 +61,7 @@ This mode is an extended emacs-lisp mode.
55 (kill-all-local-variables) 61 (kill-all-local-variables)
56 (use-local-map gnus-score-mode-map) 62 (use-local-map gnus-score-mode-map)
57 (gnus-score-make-menu-bar) 63 (gnus-score-make-menu-bar)
58 (set-syntax-table emacs-lisp-mode-syntax-table) 64 (set-syntax-table score-mode-syntax-table)
59 (setq major-mode 'gnus-score-mode) 65 (setq major-mode 'gnus-score-mode)
60 (setq mode-name "Score") 66 (setq mode-name "Score")
61 (lisp-mode-variables nil) 67 (lisp-mode-variables nil)
@@ -83,7 +89,8 @@ This mode is an extended emacs-lisp mode.
83 (goto-char (point-min)) 89 (goto-char (point-min))
84 (let ((form (read (current-buffer)))) 90 (let ((form (read (current-buffer))))
85 (erase-buffer) 91 (erase-buffer)
86 (pp form (current-buffer))) 92 (let ((emacs-lisp-mode-syntax-table score-mode-syntax-table))
93 (pp form (current-buffer))))
87 (goto-char (point-min))) 94 (goto-char (point-min)))
88 95
89(defun gnus-score-edit-exit () 96(defun gnus-score-edit-exit ()