diff options
| author | Lars Magne Ingebrigtsen | 1999-02-20 14:05:57 +0000 |
|---|---|---|
| committer | Lars Magne Ingebrigtsen | 1999-02-20 14:05:57 +0000 |
| commit | 6748645fc3dd1604ed57a883b7c346128af27d90 (patch) | |
| tree | c4c528db7873d3ef96121c002b4d09209c305dca | |
| parent | 44a6ed57c9af413959fdebe38649c0df4a055fca (diff) | |
| download | emacs-6748645fc3dd1604ed57a883b7c346128af27d90.tar.gz emacs-6748645fc3dd1604ed57a883b7c346128af27d90.zip | |
Upgrading to Gnus 5.7; see ChangeLog
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. | ||
| 99 | This variable can also be a list of regexps of headers to be ignored. | 116 | This variable can also be a list of regexps of headers to be ignored. |
| 100 | If `gnus-visible-headers' is non-nil, this variable will be ignored." | 117 | If `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. |
| 109 | This variable can also be a list of regexp of headers to remain visible. | 126 | This variable can also be a list of regexp of headers to remain visible. |
| 110 | If this variable is non-nil, `gnus-ignored-headers' will be ignored." | 127 | If 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. |
| 123 | If it is non-nil, headers that match the regular expressions will | 140 | If it is non-nil, headers that match the regular expressions will |
| 124 | be placed first in the article buffer in the sequence specified by | 141 | be placed first in the article buffer in the sequence specified by |
| 125 | this list." | 142 | this 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. |
| 131 | Possible values in this list are `empty', `newsgroups', `followup-to', | 148 | Possible 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 | |||
| 153 | will be called without any parameters, and if it returns nil, there is | 172 | will be called without any parameters, and if it returns nil, there is |
| 154 | no signature in the buffer. If it is a string, it will be used as a | 173 | no signature in the buffer. If it is a string, it will be used as a |
| 155 | regexp. If it matches, the text in question is not a signature." | 174 | regexp. 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. |
| 167 | If it is a string, the command will be executed in a sub-shell | 189 | If it is a string, the command will be executed in a sub-shell |
| 168 | asynchronously. The compressed face will be piped to this command." | 190 | asynchronously. 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. |
| 197 | Each item looks like this: | 219 | Each 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. |
| 245 | See `format-time-zone' for the possible values." | 267 | See `format-time-string' for the possible values. |
| 246 | :type 'string | 268 | |
| 269 | The variable can also be function, which should return a complete Date | ||
| 270 | header. The function is called with one argument, the time, which can | ||
| 271 | be 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. |
| 331 | For instance, if you would like to save articles related to Gnus in | 357 | For instance, if you would like to save articles related to Gnus in |
| 332 | the file \"gnus-stuff\", and articles related to VM in \"vm-stuff\", | 358 | the file \"gnus-stuff\", and articles related to VM in \"vm-stuff\", |
| 333 | you could set this variable to something like: | 359 | you 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 | |||
| 347 | a possible file name; and if it returns a non-nil list, that list will | 373 | a possible file name; and if it returns a non-nil list, that list will |
| 348 | be used as possible file names." | 374 | be 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''. |
| 378 | The function is called from the article buffer." | 404 | The 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 | ||
| 519 | An alist of the form (HEADER NAME CONTENT). | 543 | An 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.") | |||
| 630 | If given a negative prefix, always show; if given a positive prefix, | 657 | If given a negative prefix, always show; if given a positive prefix, |
| 631 | always hide." | 658 | always 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. | ||
| 827 | FROM is a string of characters to translate from; to is a string of | ||
| 828 | characters 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. | ||
| 1497 | The numerical prefix says how frequently (in seconds) the function | ||
| 1498 | is 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. |
| 1382 | This format is defined by the `gnus-article-time-format' variable." | 1515 | This 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. |
| 1546 | Optional argument FILENAME specifies file name. | 1686 | Optional argument FILENAME specifies file name. |
| 1547 | Directory to save to is default to `gnus-article-save-directory'." | 1687 | Directory 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. |
| 1562 | Optional argument FILENAME specifies file name. | 1701 | Optional argument FILENAME specifies file name. |
| 1563 | Directory to save to is default to `gnus-article-save-directory'." | 1702 | Directory 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. |
| 1581 | Optional argument FILENAME specifies file name. | 1719 | Optional argument FILENAME specifies file name. |
| 1582 | Directory to save to is default to `gnus-article-save-directory'." | 1720 | Directory 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. |
| 1600 | Optional argument FILENAME specifies file name. | 1737 | Optional argument FILENAME specifies file name. |
| 1601 | The directory to save in defaults to `gnus-article-save-directory'." | 1738 | The 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. |
| 1607 | Optional argument FILENAME specifies file name. | 1743 | Optional argument FILENAME specifies file name. |
| 1608 | The directory to save in defaults to `gnus-article-save-directory'." | 1744 | The 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. |
| 2063 | Provided for backwards compatibility." | 2196 | Provided 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. |
| 2287 | This means that PGP stuff, signatures, cited text and (some) | 2433 | This means that PGP stuff, signatures, cited text and (some) |
| 2288 | headers will be hidden. | 2434 | headers will be hidden. |
| 2289 | If given a prefix, show the hidden text instead." | 2435 | If 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 | ||
| 2595 | Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where | 2777 | Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where |
| 2596 | REGEXP: is the string matching text around the button, | 2778 | REGEXP: 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 | ||
| 2627 | This alist is very similar to `gnus-button-alist', except that each | 2809 | This alist is very similar to `gnus-button-alist', except that each |
| 2628 | alist has an additional HEADER element first in each entry: | 2810 | alist 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 | |||
| 58 | If you only want to cache your nntp groups, you could set this | ||
| 59 | variable to \"^nntp\". | ||
| 60 | |||
| 61 | If a group matches both gnus-cacheable-groups and gnus-uncacheable-groups | ||
| 62 | it'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 | ||
| 66 | If you want to avoid caching your nnml groups, you could set this | 70 | If you want to avoid caching your nnml groups, you could set this |
| 67 | variable to \"^nnml\"." | 71 | variable to \"^nnml\". |
| 72 | |||
| 73 | If a group matches both gnus-cacheable-groups and gnus-uncacheable-groups | ||
| 74 | it'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\"." | |||
| 316 | If not given a prefix, use the process marked articles instead. | 330 | If not given a prefix, use the process marked articles instead. |
| 317 | Returns the list of articles entered." | 331 | Returns 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." | |||
| 338 | If not given a prefix, use the process marked articles instead. | 351 | If not given a prefix, use the process marked articles instead. |
| 339 | Returns the list of articles removed." | 352 | Returns 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 |
| 45 | article has citations." | 42 | article 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. |
| 88 | The first grouping must match prefixes added by other packages." | 90 | The 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. |
| 112 | The text matching the first grouping will be used as a button." | 114 | The 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 | ||
| 242 | When there are citations from multiple articles in the same message, | 244 | When there are citations from multiple articles in the same message, |
| 243 | Gnus will try to give each citation from each article its own face. | 245 | Gnus 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'. | |||
| 449 | If given a negative prefix, always show; if given a positive prefix, | 457 | If given a negative prefix, always show; if given a positive prefix, |
| 450 | always hide." | 458 | always 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 | |||
| 520 | cited text with attributions. When called interactively, these two | 555 | cited text with attributions. When called interactively, these two |
| 521 | variables are ignored. | 556 | variables are ignored. |
| 522 | See also the documentation for `gnus-article-highlight-citation'." | 557 | See 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") "\ |
| 158 | An arbitrary comment on the group.")) | 158 | An arbitrary comment on the group.") |
| 159 | |||
| 160 | (visible (const :tag "Permanently visible" t) "\ | ||
| 161 | Always display this group, even when there are no unread articles | ||
| 162 | in it..")) | ||
| 159 | "Alist of valid group parameters. | 163 | "Alist of valid group parameters. |
| 160 | 164 | ||
| 161 | Each entry has the form (NAME TYPE DOC), where NAME is the parameter | 165 | Each 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 |
| 284 | for a thread.") | 287 | for a thread.") |
| 285 | 288 | ||
| 286 | (files (repeat :tag "Files" file) "\ | 289 | (files (repeat :inline t :tag "Files" file) "\ |
| 287 | The value of this entry should be any number of file names. | 290 | The value of this entry should be any number of file names. |
| 288 | These files are assumed to be score files as well, and will be loaded | 291 | These files are assumed to be score files as well, and will be loaded |
| 289 | the same way this one was.") | 292 | the 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) "\ |
| 292 | The clue of this entry should be any number of files. | 295 | The clue of this entry should be any number of files. |
| 293 | These files will not be loaded, even though they would normally be so, | 296 | These files will not be loaded, even though they would normally be so, |
| 294 | for some reason or other.") | 297 | for 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. | ||
| 267 | If no commands have gone out via nntp during the last five | ||
| 268 | minutes, 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. |
| 88 | Call EXIT-FUNC on exit. Display DOCUMENTATION in the beginning | 88 | Call EXIT-FUNC on exit. Display DOCUMENTATION in the beginning |
| 89 | of the buffer." | 89 | of 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. |
| 343 | list of score files to use. See the gnus variable | 343 | See the gnus variable gnus-score-find-score-files-function. |
| 344 | gnus-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, |
| 347 | you should see the offset and scale variables. At this point, I don't | 346 | you 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 | 672 | If 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 | ||
| 90 | If nil, no groups are permanently visible." | 92 | If 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 | ||
| 321 | Below is a list of `Form'/`Face' pairs. When deciding how a a | 326 | Below is a list of `Form'/`Face' pairs. When deciding how a a |
| 322 | particular group line should be displayed, each form is | 327 | particular 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. | ||
| 1452 | FUNCTION will be called with the group name as the paremeter | 1468 | FUNCTION will be called with the group name as the paremeter |
| 1453 | and with point over the group in question." | 1469 | and 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. |
| 1470 | If the prefix argument ALL is non-nil, already read articles become | 1486 | If the prefix argument ALL is non-nil, already read articles become |
| 1471 | readable. IF ALL is a number, fetch this number of articles. If the | 1487 | readable. 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\". |
| 1511 | This means that no highlighting or scoring will be performed. | 1527 | This means that no highlighting or scoring will be performed. |
| 1512 | If ALL (the prefix argument) is 0, don't even generate the summary | 1528 | If ALL (the prefix argument) is 0, don't even generate the summary |
| 1513 | buffer." | 1529 | buffer. |
| 1530 | |||
| 1531 | This might be useful if you want to toggle threading | ||
| 1532 | before 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." | |||
| 1552 | Returns whether the fetching was successful or not." | 1567 | Returns 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. |
| 1565 | If ACTIVATE, request the group first. | 1594 | If ACTIVATE, request the group first. |
| 1566 | If QUIT-CONFIG, use that window configuration when exiting from the | 1595 | If QUIT-CONFIG, use that window configuration when exiting from the |
| 1567 | ephemeral group. | 1596 | ephemeral group. |
| 1568 | If REQUEST-ONLY, don't actually read the group; just request it. | 1597 | If REQUEST-ONLY, don't actually read the group; just request it. |
| 1598 | If SELECT-ARTICLES, only select those articles. | ||
| 1569 | 1599 | ||
| 1570 | Return the name of the group is selection was successful." | 1600 | Return 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. |
| 2398 | If prefix argument N is numeric, the ARG next newsgroups will be | 2432 | If prefix argument N is numeric, the next N newsgroups will be |
| 2399 | caught up. If ALL is non-nil, marked articles will also be marked as | 2433 | caught up. If ALL is non-nil, marked articles will also be marked as |
| 2400 | read. Cross references (Xref: header) of articles are ignored. | 2434 | read. Cross references (Xref: header) of articles are ignored. |
| 2401 | The difference between N and actual number of newsgroups that were | 2435 | The number of newsgroups that this function was unable to catch |
| 2402 | caught up is returned." | 2436 | up 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. |
| 2719 | inserting it before the current newsgroup. The numeric ARG specifies | 2756 | The numeric ARG specifies how many newsgroups are to be yanked. The |
| 2720 | how many newsgroups are to be yanked. The name of the newsgroup yanked | 2757 | name of the newsgroup yanked is returned, or (if several groups are |
| 2721 | is returned, or (if several groups are yanked) a list of yanked groups | 2758 | yanked) a list of yanked groups is returned." |
| 2722 | is 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. |
| 3106 | Each new group will be treated with `gnus-subscribe-newsgroup-method.' | 3144 | Each new group will be treated with `gnus-subscribe-newsgroup-method.' |
| 3107 | If ARG (the prefix), use the `ask-server' method to query | 3145 | With 1 C-u, use the `ask-server' method to query the server for new |
| 3108 | the server for new groups." | 3146 | groups. |
| 3109 | (interactive "P") | 3147 | With 2 C-u's, use most complete method possible to query the server |
| 3110 | (gnus-find-new-newsgroups arg) | 3148 | for 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. |
| 3115 | If GROUP, edit that local kill file instead." | 3155 | If GROUP, edit that local kill file instead." |
| @@ -3137,18 +3177,15 @@ If GROUP, edit that local kill file instead." | |||
| 3137 | In fact, cleanup buffers except for group mode buffer. | 3177 | In fact, cleanup buffers except for group mode buffer. |
| 3138 | The hook gnus-suspend-gnus-hook is called before actually suspending." | 3178 | The 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) |
| 210 | If METHOD is a string, it is interpreted as a group name. The method | 229 | "Return the status message from GNUS-COMMAND-METHOD. |
| 230 | If GNUS-COMMAND-METHOD is a string, it is interpreted as a group name. The method | ||
| 211 | this group uses will be queried." | 231 | this 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. |
| 254 | If FETCH-OLD, retrieve all headers (or some subset thereof) in the group." | 281 | If 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. |
| 286 | ARTICLE can either be an article number or an article Message-ID. | 323 | ARTICLE can either be an article number or an article Message-ID. |
| 287 | If BUFFER, insert the article in that group." | 324 | If 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) |
| 335 | If 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)) | 396 | If 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. |
| 679 | Usage: emacs -batch -l gnus -f gnus-batch-score <newsgroups> ... | 680 | Usage: emacs -batch -l ~/.emacs -l gnus -f gnus-batch-score" |
| 680 | Newsgroups is a list of strings in Bnews format. If you want to score | ||
| 681 | the comp hierarchy, you'd say \"comp.all\". If you would not like to | ||
| 682 | score 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. |
| 39 | If this variable is nil, Gnus will use the current method to decide | ||
| 40 | which method to use when posting. If it is non-nil, it will override | ||
| 41 | the current method. This method will not be used in mail groups and | ||
| 42 | the like, only in \"real\" newsgroups. | ||
| 43 | 40 | ||
| 44 | The value must be a valid method as discussed in the documentation of | 41 | If 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 | 42 | method when posting. If it is nil (which is the default), Gnus will |
| 46 | the case, the user will be queried for what select method to use when | 43 | use the native posting method of the server. |
| 47 | posting.") | 44 | |
| 45 | This method will not be used in mail groups and the like, only in | ||
| 46 | \"real\" newsgroups. | ||
| 47 | |||
| 48 | If not nil nor `native', the value must be a valid method as discussed | ||
| 49 | in the documentation of `gnus-select-method'. It can also be a list of | ||
| 50 | methods. If that is the case, the user will be queried for what select | ||
| 51 | method 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. | |||
| 213 | If ARG, post to the group under point. | 241 | If ARG, post to the group under point. |
| 214 | If ARG is 1, prompt for a group name." | 242 | If 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") | 313 | Uses the process-prefix convention. If given the symbolic |
| 289 | (gnus-set-global-variables) | 314 | prefix `a', cancel using the standard posting method; if not |
| 315 | post 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." | |||
| 306 | This is done simply by taking the old article and adding a Supersedes | 333 | This is done simply by taking the old article and adding a Supersedes |
| 307 | header line with the old Message-ID." | 334 | header 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. |
| 428 | If SILENT, don't prompt the user." | 460 | If 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. | ||
| 564 | Assumes 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. |
| 624 | If FULL-HEADERS (the prefix), include full headers when forwarding." | 640 | If 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 | |||
| 59 | This 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." |
| 110 | active 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. |
| 59 | Both lists have to be sorted over <." | 61 | Both 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 | ||
| 168 | article 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. |
| 177 | If ARG, pick the article on that line instead." | 180 | If 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. | ||
| 188 | Otherwise pick the article on the current line. | ||
| 189 | If 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. | ||
| 199 | Otherwise unmark the article on current line. | ||
| 200 | If 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. |
| 364 | If a number, never let the tree buffer grow taller than that number of | 379 | If a number, never let the tree buffer grow taller than that number of |
| 365 | lines." | 380 | lines." |
| 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 | ||
| 108 | This variable can also be a list of functions to be called. Each | 111 | This variable can also be a list of functions to be called. Each |
| 109 | function should either return a list of score files, or a list of | 112 | function should either return a list of score files, or a list of |
| 110 | score alists." | 113 | score alists. |
| 114 | |||
| 115 | If functions other than these pre-defined functions are used, | ||
| 116 | the `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. |
| 457 | The user will be prompted for header to score on, match type, | 479 | The user will be prompted for header to score on, match type, |
| 458 | permanence, and the string to be used. The numerical prefix will be | 480 | permanence, and the string to be used. The numerical prefix will be |
| 459 | used as score." | 481 | used 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. |
| 471 | The user will be prompted for header to score on, match type, | 493 | The user will be prompted for header to score on, match type, |
| 472 | permanence, and the string to be used. The numerical prefix will be | 494 | permanence, and the string to be used. The numerical prefix will be |
| 473 | used as score." | 495 | used 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. | |||
| 712 | DATE is the expire date, or nil for no expire, or 'now for immediate expire. | 754 | DATE is the expire date, or nil for no expire, or 'now for immediate expire. |
| 713 | If optional argument `PROMPT' is non-nil, allow user to edit match. | 755 | If optional argument `PROMPT' is non-nil, allow user to edit match. |
| 714 | If optional argument `SILENT' is nil, show effect of score entry." | 756 | If 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. | ||
| 2864 | A regexp is unsafe if it matches newline or a buffer boundary. | ||
| 2865 | |||
| 2866 | If the regexp is good, return nil. If the regexp is bad, return a | ||
| 2867 | cons cell (SYM . STRING), where the symbol SYM is `new' or `bad'. | ||
| 2868 | In the `new' case, the string is a safe replacement for REGEXP. | ||
| 2869 | In the `bad' case, the string is a unsafe subexpression of REGEXP, | ||
| 2870 | and we do not have a simple replacement to suggest. | ||
| 2871 | |||
| 2872 | See `(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. | |||
| 132 | If N is nil and any articles have been marked with the process mark, | 134 | If N is nil and any articles have been marked with the process mark, |
| 133 | move those articles instead." | 135 | move 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. | |||
| 205 | For instance, if you want to brew on all the nnml groups, as well as | 207 | For instance, if you want to brew on all the nnml groups, as well as |
| 206 | groups with \"emacs\" in the name, you could say something like: | 208 | groups 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 | |||
| 212 | Note -- 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] |
| 368 | though the two last may be nil if they are missing." | 374 | though 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. |
| 41 | It works along the same lines as a normal formatting string, | 43 | It works along the same lines as a normal formatting string, |
| 42 | with some simple extensions.") | 44 | with some simple extensions. |
| 45 | |||
| 46 | The 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. |
| 56 | If a file with the `.el' or `.elc' suffixes exists, it will be read instead." | 56 | If 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. |
| 84 | This normally finds new newsgroups by comparing the active groups the | 84 | This normally finds new newsgroups by comparing the active groups the |
| 85 | servers have already reported with those Gnus already knows, either alive | 85 | servers have already reported with those Gnus already knows, either alive |
| 86 | or killed. | 86 | or killed. |
| 87 | 87 | ||
| 88 | When any of the following are true, gnus-find-new-newsgroups will instead | 88 | When any of the following are true, `gnus-find-new-newsgroups' will instead |
| 89 | ask the servers (primary, secondary, and archive servers) to list new | 89 | ask the servers (primary, secondary, and archive servers) to list new |
| 90 | groups since the last time it checked: | 90 | groups 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 | ||
| 96 | Thus, if this variable is `ask-server' or a list of select methods or | 96 | Thus, 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, | |||
| 194 | but you won't be told how many unread articles there are in the | 194 | but you won't be told how many unread articles there are in the |
| 195 | groups." | 195 | groups." |
| 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. |
| 232 | Any lines in the active file matching this regular expression are | 233 | Any lines in the active file matching this regular expression are |
| 233 | removed from the newsgroup list before anything else is done to it, | 234 | removed from the newsgroup list before anything else is done to it, |
| 234 | thus making them effectively non-existent." | 235 | thus 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. |
| 293 | Note that this variable only deals with new groups. It has no effect | 292 | Note that this variable only deals with new groups. It has no effect |
| 294 | whatsoever on old groups. | 293 | whatsoever 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. | ||
| 341 | This 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 | |||
| 634 | prompt the user for the name of an NNTP server to use." | 657 | prompt 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. |
| 903 | Each new newsgroup will be treated with `gnus-subscribe-newsgroup-method.' | 945 | Each new newsgroup will be treated with `gnus-subscribe-newsgroup-method.' |
| 904 | The `-n' option line from .newsrc is respected. | 946 | The `-n' option line from .newsrc is respected. |
| 905 | If ARG (the prefix), use the `ask-server' method to query the server | 947 | |
| 906 | for new groups." | 948 | With 1 C-u, use the `ask-server' method to query the server for new |
| 907 | (interactive "P") | 949 | groups. |
| 908 | (let ((check (if (or (and arg (not (listp gnus-check-new-newsgroups))) | 950 | With 2 C-u's, use most complete method possible to query the server |
| 909 | (null gnus-read-active-file) | 951 | for 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 | |||
| 47 | just marked as read) article, the old article will not normally be | 51 | just marked as read) article, the old article will not normally be |
| 48 | displayed in the Summary buffer. If this variable is non-nil, Gnus | 52 | displayed in the Summary buffer. If this variable is non-nil, Gnus |
| 49 | will attempt to grab the headers to the old articles, and thereby | 53 | will attempt to grab the headers to the old articles, and thereby |
| 50 | build complete threads. If it has the value `some', only enough | 54 | build complete threads. If it has the value `some', only enough |
| 51 | headers to connect otherwise loose threads will be displayed. | 55 | headers to connect otherwise loose threads will be displayed. This |
| 52 | This variable can also be a number. In that case, no more than that | 56 | variable can also be a number. In that case, no more than that number |
| 53 | number of old headers will be fetched. | 57 | of old headers will be fetched. If it has the value `invisible', all |
| 58 | old headers will be fetched, but none will be displayed. | ||
| 54 | 59 | ||
| 55 | The server has to support NOV for any of this to work." | 60 | The 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]. | ||
| 69 | If 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. |
| 64 | If the root of a thread has expired or been read in a previous | 76 | If 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. | ||
| 128 | The functions are applied recursively. | ||
| 129 | |||
| 130 | Useful 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. |
| 134 | There are two pre-defined functions: `gnus-gather-threads-by-subject', | 155 | There are two pre-defined functions: `gnus-gather-threads-by-subject', |
| 135 | which only takes Subjects into consideration; and | 156 | which 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. |
| 146 | This variable will only be used if the value of | 166 | This 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. |
| 205 | If nil, which is the default, articles that have different subjects | 225 | If nil, articles that have different subjects from their parents will |
| 206 | from their parents will start separate threads." | 226 | start 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. |
| 288 | If there are no more articles with the same subject, go to | ||
| 289 | the 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. |
| 300 | If nil, each group will get its own article buffer." | 322 | If 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. |
| 320 | It uses the same syntax as the `gnus-split-methods' variable." | 342 | It 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. |
| 465 | It works along the same lines as a normal formatting string, | 502 | It works along the same lines as a normal formatting string, |
| 466 | with some simple extensions. | 503 | with 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. |
| 585 | This 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. |
| 553 | See `gnus-thread-score-function' for en explanation of what a | 592 | See `gnus-thread-score-function' for en explanation of what a |
| 554 | \"thread score\" is." | 593 | \"thread score\" is. |
| 594 | |||
| 595 | This 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. |
| 585 | This hook is commonly used to customize threading variables and the | 631 | This 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 | ||
| 725 | A list of (FORM . FACE) pairs. When deciding how a a particular | 778 | A list of (FORM . FACE) pairs. When deciding how a a particular |
| 726 | summary line should be displayed, each form is evaluated. The content | 779 | summary 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. | ||
| 795 | The function is called with one parameter, the article header vector, | ||
| 796 | which 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. |
| 1015 | See gnus-simplify-buffer-fuzzy for details." | 1100 | See `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. |
| 1038 | simple-first is t, first argument is already simplified." | 1129 | If optional argument simple-first is t, first argument is already |
| 1130 | simplified." | ||
| 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. | ||
| 2204 | This macro should only be used when computing the mark the \"first\" | ||
| 2205 | time; i.e., when generating the summary lines. After that, | ||
| 2206 | `gnus-summary-article-mark' should be used to examine the | ||
| 2207 | marks 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. |
| 2494 | If SHOW-ALL is non-nil, already read articles are also listed. | 2541 | If SHOW-ALL is non-nil, already read articles are also listed. |
| 2495 | If NO-ARTICLE is non-nil, no article is selected initially. | 2542 | If 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 | |||
| 2904 | If FORCE-NEW is not nil, enter HEADER into the DEPENDENCIES table even | ||
| 2905 | if it was already present. | ||
| 2906 | |||
| 2907 | If `gnus-summary-ignore-duplicates' is nil then duplicate Message-IDs | ||
| 2908 | will not be entered in the DEPENDENCIES table. Otherwise duplicate | ||
| 2909 | Message-IDs will be renamed be renamed to a unique Message-ID before | ||
| 2910 | being entered. | ||
| 2911 | |||
| 2912 | Returns 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. |
| 3235 | If 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. |
| 3619 | If READ-ALL is non-nil, all articles in the group are selected." | 3852 | If READ-ALL is non-nil, all articles in the group are selected. |
| 3853 | If 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) | 4600 | OLD-HEADER can either be a header or a line number to insert |
| 4464 | old-header (gnus-read-header id))) | 4601 | the 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. |
| 4507 | the list of process marked articles, and the current article will be | 4655 | The prefix argument, the list of process marked articles, and the |
| 4508 | taken into consideration." | 4656 | current 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. | ||
| 4701 | ARG is the interactive prefix given to the command. FORMS will be | ||
| 4702 | executed 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. |
| 4815 | The prefix argument ALL means to select all articles." | 4989 | The 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. |
| 5002 | which existed when entering the ephemeral is reset." | 5186 | The 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 | |||
| 5148 | initially. If NEXT-GROUP, go to this group. If BACKWARD, go to | 5331 | initially. If NEXT-GROUP, go to this group. If BACKWARD, go to |
| 5149 | previous group instead." | 5332 | previous 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. |
| 5203 | If UNREAD is non-nil, go to the first unread article. | 5386 | If UNREAD is non-nil, go to the first unread article. |
| 5204 | Returns the article selected or nil if there are no unread articles." | 5387 | Returns 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. |
| 5293 | Given a prefix, will force an `article' buffer configuration." | 5484 | Given 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. | |||
| 5369 | If SUBJECT, only articles with SUBJECT are selected. | 5559 | If SUBJECT, only articles with SUBJECT are selected. |
| 5370 | If BACKWARD, the previous article is selected instead of the next." | 5560 | If 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. | |||
| 5543 | If MOVE, move to the previous unread article if point is at | 5735 | If MOVE, move to the previous unread article if point is at |
| 5544 | the beginning of the buffer." | 5736 | the 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. |
| 5580 | Argument LINES specifies lines to be scrolled up (or down if negative)." | 5771 | Argument 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. | ||
| 5787 | Argument 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. |
| 5621 | Return nil if there are no unread articles." | 5813 | Return 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. |
| 5633 | Return nil if there are no articles." | 5824 | Return 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. |
| 5672 | If ALL-HEADERS is non-nil, no header lines are hidden." | 5861 | If ALL-HEADERS is non-nil, no header lines are hidden. |
| 5862 | If FORCE, go to the article even if it isn't displayed. If FORCE | ||
| 5863 | is 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. |
| 5712 | If not given a prefix, use the process marked articles instead." | 5907 | If 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. |
| 5723 | If given a prefix, remove all limits." | 5917 | If 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 | |||
| 5810 | not marked with MARKS. MARKS can either be a string of marks or a | 6005 | not marked with MARKS. MARKS can either be a string of marks or a |
| 5811 | list of marks. | 6006 | list of marks. |
| 5812 | Returns how many articles were removed." | 6007 | Returns 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. |
| 6050 | Note that this command only works on a subset of the articles currently | ||
| 6051 | fetched 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." | |||
| 6121 | If N is negative, go to ancestor -N instead. | 6331 | If N is negative, go to ancestor -N instead. |
| 6122 | The difference between N and the number of articles fetched is returned." | 6332 | The 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. |
| 6165 | Return how many articles were fetched." | 6374 | Return 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. | ||
| 6395 | If LIMIT (the numerical prefix), fetch that many old headers instead | ||
| 6396 | of 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. |
| 6187 | If ARG (the prefix), fetch the article using `gnus-refer-article-method' | 6419 | If 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. |
| 6233 | If FORCE, force a digest interpretation. If not, try | 6472 | If FORCE, force a digest interpretation. If not, try |
| 6234 | to guess what the document format is." | 6473 | to 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. |
| 6332 | If REGEXP-P (the prefix) is non-nil, do regexp isearch." | 6570 | If 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 | |||
| 6749 | If N is negative, print the N previous articles. If N is nil and articles | ||
| 6750 | have been marked with the process mark, print these instead. | ||
| 6514 | 6751 | ||
| 6515 | If the optional argument FILENAME is nil, send the image to the printer. | 6752 | If the optional second argument FILENAME is nil, send the image to the |
| 6516 | If FILENAME is a string, save the PostScript image in a file with that | 6753 | printer. If FILENAME is a string, save the PostScript image in a file with |
| 6517 | name. If FILENAME is a number, prompt the user for the name of the file | 6754 | that name. If FILENAME is a number, prompt the user for the name of the file |
| 6518 | to save in." | 6755 | to 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. |
| 6534 | If ARG (the prefix) is non-nil, show the raw article without any | 6785 | If ARG (the prefix) is non-nil, show the raw article without any |
| 6535 | article massaging functions being run." | 6786 | article 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." | |||
| 6554 | If ARG is a positive number, turn header display on. | 6804 | If ARG is a positive number, turn header display on. |
| 6555 | If ARG is a negative number, turn header display off." | 6805 | If 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." | |||
| 6568 | If ARG is a positive number, show the entire header. | 6817 | If ARG is a positive number, show the entire header. |
| 6569 | If ARG is a negative number, hide the unwanted header lines." | 6818 | If 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. |
| 6602 | If ARG is a positive number, turn MIME processing on." | 6849 | If 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." | |||
| 6612 | The numerical prefix specifies how many places to rotate each letter | 6858 | The numerical prefix specifies how many places to rotate each letter |
| 6613 | forward." | 6859 | forward." |
| 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." | |||
| 7020 | This means that *all* articles that are marked as expirable will be | 7260 | This means that *all* articles that are marked as expirable will be |
| 7021 | deleted forever, right now." | 7261 | deleted 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. | |||
| 7037 | If N is nil and articles have been marked with the process mark, | 7276 | If N is nil and articles have been marked with the process mark, |
| 7038 | delete these instead." | 7277 | delete 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. | ||
| 7424 | Display 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." | |||
| 7183 | If UNMARK is positive, remove any kind of mark. | 7432 | If UNMARK is positive, remove any kind of mark. |
| 7184 | If UNMARK is negative, tick articles." | 7433 | If 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." | |||
| 7202 | If UNMARK is positive, remove any kind of mark. | 7450 | If UNMARK is positive, remove any kind of mark. |
| 7203 | If UNMARK is negative, tick articles." | 7451 | If 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 | |||
| 7253 | the process mark instead. The difference between N and the actual | 7500 | the process mark instead. The difference between N and the actual |
| 7254 | number of articles marked is returned." | 7501 | number 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. |
| 7275 | If N is negative, mark backward instead. The difference between N and | 7521 | If N is negative, unmark backward instead. The difference between N and |
| 7276 | the actual number of articles marked is returned." | 7522 | the 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." | |||
| 7292 | If N is negative, mark backward instead. The difference between N and | 7536 | If N is negative, mark backward instead. The difference between N and |
| 7293 | the actual number of articles marked is returned." | 7537 | the 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." | |||
| 7351 | If N is negative, mark backward instead. The difference between N and | 7592 | If N is negative, mark backward instead. The difference between N and |
| 7352 | the actual number of articles marked is returned." | 7593 | the 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. | |||
| 7382 | The difference between N and the actual number of articles marked is | 7624 | The difference between N and the actual number of articles marked is |
| 7383 | returned." | 7625 | returned." |
| 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 | |||
| 7766 | in the current summary buffer limitation. | 8017 | in the current summary buffer limitation. |
| 7767 | The number of articles marked as read is returned." | 8018 | The 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. |
| 7804 | If ALL is non-nil, also mark ticked and dormant articles as read." | 8054 | If 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. |
| 7823 | If prefix argument ALL is non-nil, all articles are marked as read." | 8071 | If 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." | |||
| 7841 | If given a prefix, mark all articles, unread as well as ticked, as | 8088 | If given a prefix, mark all articles, unread as well as ticked, as |
| 7842 | read." | 8089 | read." |
| 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. |
| 7948 | If ARG is positive number, turn showing conversation threads on." | 8200 | If 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. |
| 7971 | Returns nil if no thread was there to be shown." | 8221 | Returns 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. |
| 7999 | Returns nil if no threads were there to be hidden." | 8247 | Returns 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 | ||
| 8048 | If SILENT, don't output messages." | 8295 | If 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." | |||
| 8064 | Returns the difference between N and the number of skips actually | 8310 | Returns the difference between N and the number of skips actually |
| 8065 | done." | 8311 | done." |
| 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. | |||
| 8085 | Returns the difference between N and how many steps down that were | 8330 | Returns the difference between N and how many steps down that were |
| 8086 | taken." | 8331 | taken." |
| 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. | |||
| 8103 | Returns the difference between N and how many steps down that were | 8347 | Returns the difference between N and how many steps down that were |
| 8104 | taken." | 8348 | taken." |
| 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." | |||
| 8118 | If the prefix argument is positive, remove any kinds of marks. | 8360 | If the prefix argument is positive, remove any kinds of marks. |
| 8119 | If the prefix argument is negative, tick articles instead." | 8361 | If 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, | |||
| 8220 | save those articles instead. | 8460 | save those articles instead. |
| 8221 | The variable `gnus-default-article-saver' specifies the saver function." | 8461 | The 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. | |||
| 8257 | If N is nil and any articles have been marked with the process mark, | 8496 | If N is nil and any articles have been marked with the process mark, |
| 8258 | pipe those articles instead." | 8497 | pipe 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. | |||
| 8269 | If N is nil and any articles have been marked with the process mark, | 8507 | If N is nil and any articles have been marked with the process mark, |
| 8270 | save those articles instead." | 8508 | save 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. | |||
| 8280 | If N is nil and any articles have been marked with the process mark, | 8517 | If N is nil and any articles have been marked with the process mark, |
| 8281 | save those articles instead." | 8518 | save 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. | |||
| 8291 | If N is nil and any articles have been marked with the process mark, | 8527 | If N is nil and any articles have been marked with the process mark, |
| 8292 | save those articles instead." | 8528 | save 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. | |||
| 8302 | If N is nil and any articles have been marked with the process mark, | 8537 | If N is nil and any articles have been marked with the process mark, |
| 8303 | save those articles instead." | 8538 | save 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. | |||
| 8313 | If N is nil and any articles have been marked with the process mark, | 8547 | If N is nil and any articles have been marked with the process mark, |
| 8314 | save those articles instead." | 8548 | save 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)) | 173 | If 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. |
| 359 | use the `gnus-group-topics' to sort the groups. | 368 | Use the `gnus-group-topics' to sort the groups. |
| 360 | If ALL is non-nil, list groups that have no unread articles. | 369 | If ALL is non-nil, list groups that have no unread articles. |
| 361 | If LOWEST is non-nil, list all newsgroups of level LOWEST or higher." | 370 | If 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. |
| 402 | If SILENT, don't insert anything. Return the number of unread | 415 | If SILENT, don't insert anything. Return the number of unread |
| 403 | articles in the topic and its subtopics." | 416 | articles 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." | |||
| 458 | If N, return the Nth ancestor instead." | 456 | If 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. |
| 583 | Bind `print-quoted' to t while printing." | 579 | Bind `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. | ||
| 839 | ARG 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. |
| 75 | To change the behaviour, you can either edit this variable or set | 77 | To 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. |
| 115 | See the documentation on the `gnus-uu-default-view-rules' variable for | 117 | See the documentation on the `gnus-uu-default-view-rules' variable for |
| 116 | details." | 118 | details." |
| 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. |
| 290 | The headers will be included in the sequence they are matched." | 297 | The 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 | |||
| 741 | Note that Gnus is mostly loaded when the `.gnus.el' file is read. | ||
| 742 | This means that other directory variables that are initialized from | ||
| 743 | this variable won't be set properly if you set this variable in `.gnus.el'. | ||
| 744 | Set 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. |
| 803 | This variable should be a list, where the first element is how the | 812 | This variable should be a list, where the first element is how the |
| 804 | news is to be fetched, the second is the address. | 813 | news 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. |
| 831 | This should be a mail method. | 840 | This should be a mail method. |
| 832 | 841 | ||
| 833 | It's probably not a very effective to change this variable once you've | 842 | It'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. |
| 936 | This will most commonly be on a remote machine, and the file will be | 946 | This will most commonly be on a remote machine, and the file will be |
| 937 | fetched by ange-ftp. | 947 | fetched 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. |
| 1094 | It calls `gnus-summary-expire-articles' by default." | 1104 | It 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. |
| 1107 | And that means *anything*." | 1117 | That doesn't mean *anything* anything; particularly destructive |
| 1118 | commands 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. | ||
| 1160 | The first element of each list lists should be a string with the name | 1173 | The first element of each list lists should be a string with the name |
| 1161 | of the select method. The other elements may be the category of | 1174 | of the select method. The other elements may be the category of |
| 1162 | this method (i. e., `post', `mail', `none' or whatever) or other | 1175 | this 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. |
| 1287 | If `visual' is disabled, there will be no menus and few faces. Most of | 1300 | If `visual' is disabled, there will be no menus and few faces. Most of |
| 1288 | the visual customization options below will be ignored. Gnus will use | 1301 | the visual customization options below will be ignored. Gnus will use |
| 1289 | less space and be faster as a result. | 1302 | less 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. |
| 1330 | The line beneath the mouse pointer will be highlighted with this | 1343 | The line beneath the mouse pointer will be highlighted with this |
| 1331 | face." | 1344 | face." |
| 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 | ||
| 1349 | If you leave the list empty, the article will appear exactly as it is | 1362 | If you leave the list empty, the article will appear exactly as it is |
| 1350 | stored on the disk. The list entries will hide or highlight various | 1363 | stored 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 | ||
| 1702 | It works along the same lines as a normal formatting string, | 1750 | It 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. |
| 1935 | STRINGS will be evaluated in normal `or' order." | 1977 | STRINGS 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. |
| 1954 | If ARG, insert string at point." | 1991 | If 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'. | ||
| 2047 | See `interactive' for full documentation. | ||
| 2048 | |||
| 2049 | Adds the following specs: | ||
| 2050 | |||
| 2051 | y -- The current symbolic prefix. | ||
| 2052 | Y -- A list of the current symbolic prefix(es). | ||
| 2053 | A -- Article number. | ||
| 2054 | H -- Article header. | ||
| 2055 | g -- 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. |
| 2271 | If SYMBOL, return the value of that symbol in the group parameters." | 2438 | If 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. |
| 2281 | If SYMBOL, return the value of that symbol in the group parameters." | 2448 | If SYMBOL, return the value of that symbol in the group parameters. |
| 2449 | Most functions should use `gnus-group-find-parameter', which | ||
| 2450 | also 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. |
| 2336 | Select methods are stripped and any remote host name is stripped down to | 2516 | Select methods are stripped and any remote host name is stripped down to |
| 2337 | just the host name." | 2517 | just 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. |
| 2534 | Allow completion over sensible values." | 2717 | Allow 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. |
| 163 | To disable checking of long signatures, for instance, add | 161 | To 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. | |||
| 168 | Checks include subject-cmsg multiple-headers sendsys message-id from | 166 | Checks include subject-cmsg multiple-headers sendsys message-id from |
| 169 | long-lines control-chars size new-text redirected-followup signature | 167 | long-lines control-chars size new-text redirected-followup signature |
| 170 | approved sender empty empty-headers message-id from subject | 168 | approved sender empty empty-headers message-id from subject |
| 171 | shorten-followup-to existing-newsgroups." | 169 | shorten-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. |
| 179 | RFC977 and RFC1036 require From, Date, Newsgroups, Subject, | 177 | RFC977 and RFC1036 require From, Date, Newsgroups, Subject, |
| 180 | Message-ID. Organization, Lines, In-Reply-To, Expires, and | 178 | Message-ID. Organization, Lines, In-Reply-To, Expires, and |
| 181 | X-Newsreader are optional. If don't you want message to insert some | 179 | X-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. |
| 191 | RFC822 required that From, Date, To, Subject and Message-ID be | 189 | RFC822 required that From, Date, To, Subject and Message-ID be |
| 192 | included. Organization, Lines and X-Mailer are optional." | 190 | included. 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. |
| 240 | If this is a function, call that function with three parameters: The type, | 245 | If this is a function, call that function with three parameters: The type, |
| 241 | the to address and the group name. (Any of these may be nil.) The function | 246 | the to address and the group name. (Any of these may be nil.) The function |
| 242 | should return the new buffer name." | 247 | should 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. | ||
| 275 | If 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. | ||
| 303 | The subject generated by the previous function is passed into each | ||
| 304 | successive function. | ||
| 305 | |||
| 306 | The 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 | |||
| 322 | variable `mail-header-separator'. | 341 | variable `mail-header-separator'. |
| 323 | 342 | ||
| 324 | Legal values include `message-send-mail-with-sendmail' (the default), | 343 | Legal 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. |
| 428 | Note that when posting from inside Gnus, for instance, this | ||
| 429 | variable 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." |
| 442 | buffer." | ||
| 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. |
| 469 | Predefined functions include `message-cite-original' and | 491 | Predefined functions include `message-cite-original' and |
| 470 | `message-cite-original-without-signature'. | 492 | `message-cite-original-without-signature'. |
| 471 | Note that `message-cite-original' uses `mail-citation-hook'if that is non-nil." | 493 | Note 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. |
| 543 | It is inserted before you edit the message, so you can edit or delete | 571 | It is inserted before you edit the message, so you can edit or delete |
| 544 | these lines." | 572 | these 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 |
| 556 | articles." | 584 | articles." |
| 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.) |
| 583 | The value should be an expression to test whether the problem will | 611 | The value should be an expression to test whether the problem will |
| 584 | actually occur." | 612 | actually occur." |
| @@ -616,6 +644,13 @@ the prefix.") | |||
| 616 | The default is `abbrev', which uses mailabbrev. nil switches | 644 | The default is `abbrev', which uses mailabbrev. nil switches |
| 617 | mail aliases off.") | 645 | mail 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. | ||
| 650 | If 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. | |||
| 1017 | If FIRST, only remove the first instance of the header. | 1071 | If FIRST, only remove the first instance of the header. |
| 1018 | Return the number of headers removed." | 1072 | Return 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). | |||
| 1230 | C-c C-y message-yank-original (insert current message, if any). | 1294 | C-c C-y message-yank-original (insert current message, if any). |
| 1231 | C-c C-q message-fill-yanked-message (fill what was yanked). | 1295 | C-c C-q message-fill-yanked-message (fill what was yanked). |
| 1232 | C-c C-e message-elide-region (elide the text between point and mark). | 1296 | C-c C-e message-elide-region (elide the text between point and mark). |
| 1297 | C-c C-z message-kill-to-signature (kill the text up to the signature). | ||
| 1233 | C-c C-r message-caesar-buffer-body (rot13 the message body)." | 1298 | C-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. |
| 1456 | If there is no signature in the article, go to the end and | ||
| 1457 | return 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. |
| 1451 | message-elide-elipsis) will be inserted where the text was killed." | 1581 | An ellipsis (from `message-elide-elipsis') will be inserted where the |
| 1582 | text 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. |
| 1502 | Used to encode/decode possibly offensive messages (commonly in net.jokes). | 1633 | Used to encode/decode possiblyun offensive messages (commonly in net.jokes). |
| 1503 | With prefix arg, specifies the number of places to rotate each letter forward. | 1634 | With prefix arg, specifies the number of places to rotate each letter forward. |
| 1504 | Mail and USENET news headers are not rotated." | 1635 | Mail 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. | |||
| 1756 | Otherwise any failure is reported in a message back to | 1915 | Otherwise any failure is reported in a message back to |
| 1757 | the user from the mailer." | 1916 | the 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. |
| 3247 | OTHER-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.")) | |||
| 3341 | This is done simply by taking the old article and adding a Supersedes | 3539 | This is done simply by taking the old article and adding a Supersedes |
| 3342 | header line with the old Message-ID." | 3540 | header 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. | ||
| 3625 | The form is: [Source] Subject, where if the original message was mail, | ||
| 3626 | Source is the sender, and if the original message was news, Source is | ||
| 3627 | the 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. | ||
| 3636 | The form is: Fwd: Subject, where Subject is the original subject of | ||
| 3637 | the 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. |
| 57 | The function `message-setup' runs this hook.") | 57 | The 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. | |||
| 69 | If a function, the result from the function will be used instead. | 70 | If a function, the result from the function will be used instead. |
| 70 | If a form, the result from the form will be used instead.") | 71 | If 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. | ||
| 86 | The headers should be delimited by a line whose contents match the | ||
| 87 | variable `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. |
| 39 | One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward', | 40 | One 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. | ||
| 49 | The default function removes all trailing carriage returns | ||
| 50 | from 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. | ||
| 666 | When a MIME entity contains sub-entities, dissection produces one article for | ||
| 667 | the 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\\|\ | ||
| 680 | MIME-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. | ||
| 690 | The article, which corresponds to a MIME entity, extends from BEGIN to END. | ||
| 691 | The string POSITION holds a dotted decimal representation of the article | ||
| 692 | position in the hierarchical structure, it is nil for the outer entity. | ||
| 693 | The 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 | |||
| 607 | first definition, and if any other symbol, add after that | 764 | first definition, and if any other symbol, add after that |
| 608 | symbol in the alist." | 765 | symbol 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 | 488 | ARTICLE can be an article number or a Message-ID. |
| 489 | (delete-region | 489 | Returns 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. | ||
| 512 | If optional argument LEAVE-DELIM is t, then mailbox delimiter is not | ||
| 513 | deleted. 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. | ||
| 601 | If 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\". |
| 182 | Finds out what articles are to be part of the nnkiboze groups." | 184 | Finds 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 | ||
| 79 | If you'd like, for instance, one mail group for mail from the | 82 | If 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. |
| 175 | This variable is \"/usr/spool/mail/$user\" by default. | 178 | This variable is \"/usr/spool/mail/$user\" by default. |
| 176 | If this variable is nil, no mail backends will read incoming mail. | 179 | If this variable is nil, no mail backends will read incoming mail. |
| 177 | If this variable is a list, all files mentioned in this list will be | 180 | If this variable is a list, all files mentioned in this list will be |
| @@ -179,7 +182,8 @@ used as incoming mailboxes. | |||
| 179 | If this variable is a directory (i. e., it's name ends with a \"/\"), | 182 | If this variable is a directory (i. e., it's name ends with a \"/\"), |
| 180 | treat all files in that directory as incoming spool files." | 183 | treat 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. |
| 223 | This is `add-name-to-file' by default, which means that crossposts | 227 | This is `add-name-to-file' by default, which means that crossposts |
| 224 | will use hard links. If your file system doesn't allow hard | 228 | will use hard links. If your file system doesn't allow hard |
| 225 | links, you could set this variable to `copy-file' instead." | 229 | links, 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. |
| 252 | The incoming mail is moved from `nnmail-spool-file' (which normally is | 256 | The incoming mail is moved from `nnmail-spool-file' (which normally is |
| 253 | something like \"/usr/spool/mail/$user\") to the user's home | 257 | something like \"/usr/spool/mail/$user\") to the user's home |
| 254 | directory. This hook is called after the incoming mail box has been | 258 | directory. 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." | |||
| 300 | This can also be a list of regexps." | 304 | This 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. |
| 342 | To enable this, set `nnmail-split-methods' to `nnmail-split-fancy'. | 346 | To enable this, set `nnmail-split-methods' to `nnmail-split-fancy'. |
| 343 | 347 | ||
| 344 | The format is this variable is SPLIT, where SPLIT can be one of | 348 | The format of this variable is SPLIT, where SPLIT can be one of |
| 345 | the following: | 349 | the following: |
| 346 | 350 | ||
| 347 | GROUP: Mail will be stored in GROUP (a string). | 351 | GROUP: 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 | |||
| 718 | is a spool. If not using procmail, return GROUP." | 729 | is 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. |
| 1044 | FUNC will be called with the group name to determine the article number." | 1060 | FUNC 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. | ||
| 1818 | Doesn'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. | ||
| 74 | This is necessary if using message mode outside Gnus with nnsoup as a | ||
| 75 | backend 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. |
| 47 | The default value is `nntp-send-mode-reader', which makes an innd | 47 | The default value is `nntp-send-mode-reader', which makes an innd |
| 48 | server spawn an nnrpd server. Another useful function to put in this | 48 | server spawn an nnrpd server.") |
| 49 | hook might be `nntp-send-authinfo', which will prompt for a password | ||
| 50 | to allow posting from the server. Note that this is only necessary to | ||
| 51 | do 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. |
| 52 | It 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 |
| 80 | the same.") | 78 | the same.") |
| 81 | 79 | ||
| 80 | (defvoo nntp-rlogin-program "rsh" | ||
| 81 | "*Program used to log in on remote machines. | ||
| 82 | The 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'. |
| 84 | That function may be used as `nntp-open-connection-function'. In that | 86 | That function may be used as `nntp-open-connection-function'. In that |
| 85 | case, this list will be used as the parameter list given to rsh.") | 87 | case, 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.") | |||
| 134 | If the gap between two consecutive articles is bigger than this | 142 | If the gap between two consecutive articles is bigger than this |
| 135 | variable, split the XOVER request into two requests.") | 143 | variable, 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. | ||
| 139 | If 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. |
| 143 | If can be used to set up a server remotely, for instance. Say you | 147 | If can be used to set up a server remotely, for instance. Say you |
| 144 | have an account at the machine \"other.machine\". This machine has | 148 | have an account at the machine \"other.machine\". This machine has |
| 145 | access to an NNTP server that you can't access locally. You could | 149 | access to an NNTP server that you can't access locally. You could |
| 146 | then use this hook to rsh to the remote machine and start a proxy NNTP | 150 | then use this hook to rsh to the remote machine and start a proxy NNTP |
| 147 | server there that you can connect to. See also `nntp-open-connection-function'") | 151 | server 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. | ||
| 191 | If 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 | |||
| 695 | reading." | 758 | reading." |
| 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. | ||
| 700 | This function is supposed to be called from `nntp-server-opened-hook'. | ||
| 701 | It 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. |
| 711 | This function is supposed to be called from `nntp-server-opened-hook'. | 763 | It will look in the \"~/.authinfo\" file for matching entries. If |
| 712 | It will prompt for a password." | 764 | nothing suitable is found there, it will prompt for a user name |
| 713 | (nntp-send-command "^.*\r?\n" "AUTHINFO USER" (user-login-name)) | 765 | and a password. |
| 714 | (nntp-send-command | 766 | |
| 715 | "^.*\r?\n" "AUTHINFO PASS" | 767 | If 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. |
| 720 | This function is supposed to be called from `nntp-server-opened-hook'." | 802 | |
| 803 | The authinfo login name is taken from the user's login name and the | ||
| 804 | password 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. |
| 47 | If this variable is nil (which is the default) and you read articles | 48 | If this variable is nil (which is the default) and you read articles |
| 48 | in a component group after the virtual group has been activated, the | 49 | in 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. |
| 58 | Valid types include `dejanews', `dejanewsold', `reference', | ||
| 59 | and `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 () |