diff options
| author | Dave Love | 2000-09-20 11:46:48 +0000 |
|---|---|---|
| committer | Dave Love | 2000-09-20 11:46:48 +0000 |
| commit | f4c1c47c5b311c19b4cd0c3296783fc83b6c19b9 (patch) | |
| tree | 763d0b6a222a27b2823fc943695e9361e0bf151a | |
| parent | 2ef8202d39ed4f70406cd74b22f5a8e0bc166e4d (diff) | |
| download | emacs-old-branches/branch-5_8.tar.gz emacs-old-branches/branch-5_8.zip | |
Merge from Gnus trunk.old-branches/branch-5_8
| -rw-r--r-- | lisp/gnus/gnus-art.el | 2780 | ||||
| -rw-r--r-- | lisp/gnus/gnus-group.el | 834 | ||||
| -rw-r--r-- | lisp/gnus/gnus-msg.el | 513 | ||||
| -rw-r--r-- | lisp/gnus/gnus-sum.el | 1822 | ||||
| -rw-r--r-- | lisp/gnus/gnus-topic.el | 337 | ||||
| -rw-r--r-- | lisp/gnus/gnus-util.el | 385 | ||||
| -rw-r--r-- | lisp/gnus/nnheader.el | 329 | ||||
| -rw-r--r-- | lisp/gnus/nnkiboze.el | 259 |
8 files changed, 5105 insertions, 2154 deletions
diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index ac2aed4ba71..4bc1e3fe708 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el | |||
| @@ -1,5 +1,5 @@ | |||
| 1 | ;;; gnus-art.el --- article mode commands for Gnus | 1 | ;;; gnus-art.el --- article mode commands for Gnus |
| 2 | ;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. | 2 | ;; Copyright (C) 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc. |
| 3 | 3 | ||
| 4 | ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> | 4 | ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
| 5 | ;; Keywords: news | 5 | ;; Keywords: news |
| @@ -27,20 +27,27 @@ | |||
| 27 | 27 | ||
| 28 | (eval-when-compile (require 'cl)) | 28 | (eval-when-compile (require 'cl)) |
| 29 | 29 | ||
| 30 | (eval-when-compile (require 'cl)) | ||
| 31 | |||
| 32 | (require 'custom) | ||
| 33 | (require 'gnus) | 30 | (require 'gnus) |
| 34 | (require 'gnus-sum) | 31 | (require 'gnus-sum) |
| 35 | (require 'gnus-spec) | 32 | (require 'gnus-spec) |
| 36 | (require 'gnus-int) | 33 | (require 'gnus-int) |
| 37 | (require 'browse-url) | 34 | (require 'mm-bodies) |
| 35 | (require 'mail-parse) | ||
| 36 | (require 'mm-decode) | ||
| 37 | (require 'mm-view) | ||
| 38 | (require 'wid-edit) | ||
| 39 | (require 'mm-uu) | ||
| 38 | 40 | ||
| 39 | (defgroup gnus-article nil | 41 | (defgroup gnus-article nil |
| 40 | "Article display." | 42 | "Article display." |
| 41 | :link '(custom-manual "(gnus)The Article Buffer") | 43 | :link '(custom-manual "(gnus)The Article Buffer") |
| 42 | :group 'gnus) | 44 | :group 'gnus) |
| 43 | 45 | ||
| 46 | (defgroup gnus-article-treat nil | ||
| 47 | "Treating article parts." | ||
| 48 | :link '(custom-manual "(gnus)Article Hiding") | ||
| 49 | :group 'gnus-article) | ||
| 50 | |||
| 44 | (defgroup gnus-article-hiding nil | 51 | (defgroup gnus-article-hiding nil |
| 45 | "Hiding article parts." | 52 | "Hiding article parts." |
| 46 | :link '(custom-manual "(gnus)Article Hiding") | 53 | :link '(custom-manual "(gnus)Article Hiding") |
| @@ -107,11 +114,19 @@ | |||
| 107 | "^Originator:" "^X-Problems-To:" "^X-Auth-User:" "^X-Post-Time:" | 114 | "^Originator:" "^X-Problems-To:" "^X-Auth-User:" "^X-Post-Time:" |
| 108 | "^X-Admin:" "^X-UID:" "^Resent-[-A-Za-z]+:" "^X-Mailing-List:" | 115 | "^X-Admin:" "^X-UID:" "^Resent-[-A-Za-z]+:" "^X-Mailing-List:" |
| 109 | "^Precedence:" "^Original-[-A-Za-z]+:" "^X-filename:" "^X-Orcpt:" | 116 | "^Precedence:" "^Original-[-A-Za-z]+:" "^X-filename:" "^X-Orcpt:" |
| 110 | "^Old-Received:" "^X-Pgp-Fingerprint:" "^X-Pgp-Key-Id:" | 117 | "^Old-Received:" "^X-Pgp" "^X-Auth:" "^X-From-Line:" |
| 111 | "^X-Pgp-Public-Key-Url:" "^X-Auth:" "^X-From-Line:" | ||
| 112 | "^X-Gnus-Article-Number:" "^X-Majordomo:" "^X-Url:" "^X-Sender:" | 118 | "^X-Gnus-Article-Number:" "^X-Majordomo:" "^X-Url:" "^X-Sender:" |
| 113 | "^X-Mailing-List:" "^MBOX-Line" "^Priority:" "^X-Pgp" "^X400-[-A-Za-z]+:" | 119 | "^MBOX-Line" "^Priority:" "^X-Pgp" "^X400-[-A-Za-z]+:" |
| 114 | "^Status:") | 120 | "^Status:" "^X-Gnus-Mail-Source:" "^Cancel-Lock:" |
| 121 | "^X-FTN" "^X-EXP32-SerialNo:" "^Encoding:" "^Importance:" | ||
| 122 | "^Autoforwarded:" "^Original-Encoded-Information-Types:" "^X-Ya-Pop3:" | ||
| 123 | "^X-Face-Version:" "^X-Vms-To:" "^X-ML-NAME:" "^X-ML-COUNT:" | ||
| 124 | "^Mailing-List:" "^X-finfo:" "^X-md5sum:" "^X-md5sum-Origin:" | ||
| 125 | "^X-Sun-Charset:" "^X-Accept-Language:" "^X-Envelope-Sender:" | ||
| 126 | "^List-[A-Za-z]+:" "^X-Listprocessor-Version:" | ||
| 127 | "^X-Received:" "^X-Distribute:" "^X-Sequence:" "^X-Juno-Line-Breaks:" | ||
| 128 | "^X-Notes-Item:" "^X-MS-TNEF-Correlator:" "^x-uunet-gateway:" | ||
| 129 | "^X-Received:" "^Content-length:" "X-precedence:") | ||
| 115 | "*All headers that start with this regexp will be hidden. | 130 | "*All headers that start with this regexp will be hidden. |
| 116 | This variable can also be a list of regexps of headers to be ignored. | 131 | This variable can also be a list of regexps of headers to be ignored. |
| 117 | If `gnus-visible-headers' is non-nil, this variable will be ignored." | 132 | If `gnus-visible-headers' is non-nil, this variable will be ignored." |
| @@ -121,7 +136,7 @@ If `gnus-visible-headers' is non-nil, this variable will be ignored." | |||
| 121 | :group 'gnus-article-hiding) | 136 | :group 'gnus-article-hiding) |
| 122 | 137 | ||
| 123 | (defcustom gnus-visible-headers | 138 | (defcustom gnus-visible-headers |
| 124 | "From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|X-Sent:" | 139 | "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^[BGF]?Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|^X-Sent:" |
| 125 | "*All headers that do not match this regexp will be hidden. | 140 | "*All headers that do not match this regexp will be hidden. |
| 126 | This variable can also be a list of regexp of headers to remain visible. | 141 | This variable can also be a list of regexp of headers to remain visible. |
| 127 | If this variable is non-nil, `gnus-ignored-headers' will be ignored." | 142 | If this variable is non-nil, `gnus-ignored-headers' will be ignored." |
| @@ -152,8 +167,8 @@ Possible values in this list are `empty', `newsgroups', `followup-to', | |||
| 152 | (const :tag "Followup-to identical to newsgroups." followup-to) | 167 | (const :tag "Followup-to identical to newsgroups." followup-to) |
| 153 | (const :tag "Reply-to identical to from." reply-to) | 168 | (const :tag "Reply-to identical to from." reply-to) |
| 154 | (const :tag "Date less than four days old." date) | 169 | (const :tag "Date less than four days old." date) |
| 155 | (const :tag "Very long To header." long-to) | 170 | (const :tag "Very long To and/or Cc header." long-to) |
| 156 | (const :tag "Multiple To headers." many-to)) | 171 | (const :tag "Multiple To and/or Cc headers." many-to)) |
| 157 | :group 'gnus-article-hiding) | 172 | :group 'gnus-article-hiding) |
| 158 | 173 | ||
| 159 | (defcustom gnus-signature-separator '("^-- $" "^-- *$") | 174 | (defcustom gnus-signature-separator '("^-- $" "^-- *$") |
| @@ -165,7 +180,7 @@ the end of the buffer." | |||
| 165 | :group 'gnus-article-signature) | 180 | :group 'gnus-article-signature) |
| 166 | 181 | ||
| 167 | (defcustom gnus-signature-limit nil | 182 | (defcustom gnus-signature-limit nil |
| 168 | "Provide a limit to what is considered a signature. | 183 | "Provide a limit to what is considered a signature. |
| 169 | If it is a number, no signature may not be longer (in characters) than | 184 | If it is a number, no signature may not be longer (in characters) than |
| 170 | that number. If it is a floating point number, no signature may be | 185 | that number. If it is a floating point number, no signature may be |
| 171 | longer (in lines) than that number. If it is a function, the function | 186 | longer (in lines) than that number. If it is a function, the function |
| @@ -183,12 +198,20 @@ regexp. If it matches, the text in question is not a signature." | |||
| 183 | :type 'sexp | 198 | :type 'sexp |
| 184 | :group 'gnus-article-hiding) | 199 | :group 'gnus-article-hiding) |
| 185 | 200 | ||
| 201 | ;; Fixme: This isn't the right thing for mixed graphical and and | ||
| 202 | ;; non-graphical frames in a session. | ||
| 203 | ;; gnus-xmas.el overrides this for XEmacs. | ||
| 186 | (defcustom gnus-article-x-face-command | 204 | (defcustom gnus-article-x-face-command |
| 187 | "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -" | 205 | (if (and (fboundp 'image-type-available-p) |
| 206 | (image-type-available-p 'xbm)) | ||
| 207 | 'gnus-article-display-xface | ||
| 208 | "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | display -") | ||
| 188 | "*String or function to be executed to display an X-Face header. | 209 | "*String or function to be executed to display an X-Face header. |
| 189 | If it is a string, the command will be executed in a sub-shell | 210 | If it is a string, the command will be executed in a sub-shell |
| 190 | asynchronously. The compressed face will be piped to this command." | 211 | asynchronously. The compressed face will be piped to this command." |
| 191 | :type 'string ;Leave function case to Lisp. | 212 | :type '(choice string |
| 213 | (function-item gnus-article-display-xface) | ||
| 214 | function) | ||
| 192 | :group 'gnus-article-washing) | 215 | :group 'gnus-article-washing) |
| 193 | 216 | ||
| 194 | (defcustom gnus-article-x-face-too-ugly nil | 217 | (defcustom gnus-article-x-face-too-ugly nil |
| @@ -198,7 +221,7 @@ asynchronously. The compressed face will be piped to this command." | |||
| 198 | 221 | ||
| 199 | (defcustom gnus-emphasis-alist | 222 | (defcustom gnus-emphasis-alist |
| 200 | (let ((format | 223 | (let ((format |
| 201 | "\\(\\s-\\|^\\|[-\"]\\|\\s(\\|\\s)\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\s-\\|[-?!.,;:\"]\\|\\s(\\|\\s)\\)") | 224 | "\\(\\s-\\|^\\|[-\"]\\|\\s(\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\s-\\|[-,;:\"]\\s-\\|[?!.]+\\s-\\|\\s)\\)") |
| 202 | (types | 225 | (types |
| 203 | '(("_" "_" underline) | 226 | '(("_" "_" underline) |
| 204 | ("/" "/" italic) | 227 | ("/" "/" italic) |
| @@ -232,6 +255,14 @@ is the face used for highlighting." | |||
| 232 | face)) | 255 | face)) |
| 233 | :group 'gnus-article-emphasis) | 256 | :group 'gnus-article-emphasis) |
| 234 | 257 | ||
| 258 | (defcustom gnus-emphasize-whitespace-regexp "^[ \t]+\\|[ \t]*\n" | ||
| 259 | "A regexp to describe whitespace which should not be emphasized. | ||
| 260 | Typical values are \"^[ \\t]+\\\\|[ \\t]*\\n\" and \"[ \\t]+\\\\|[ \\t]*\\n\". | ||
| 261 | The former avoids underlining of leading and trailing whitespace, | ||
| 262 | and the latter avoids underlining any whitespace at all." | ||
| 263 | :group 'gnus-article-emphasis | ||
| 264 | :type 'regexp) | ||
| 265 | |||
| 235 | (defface gnus-emphasis-bold '((t (:bold t))) | 266 | (defface gnus-emphasis-bold '((t (:bold t))) |
| 236 | "Face used for displaying strong emphasized text (*word*)." | 267 | "Face used for displaying strong emphasized text (*word*)." |
| 237 | :group 'gnus-article-emphasis) | 268 | :group 'gnus-article-emphasis) |
| @@ -262,6 +293,11 @@ is the face used for highlighting." | |||
| 262 | Esample: (_/*word*/_)." | 293 | Esample: (_/*word*/_)." |
| 263 | :group 'gnus-article-emphasis) | 294 | :group 'gnus-article-emphasis) |
| 264 | 295 | ||
| 296 | (defface gnus-emphasis-highlight-words | ||
| 297 | '((t (:background "black" :foreground "yellow"))) | ||
| 298 | "Face used for displaying highlighted words." | ||
| 299 | :group 'gnus-article-emphasis) | ||
| 300 | |||
| 265 | (defcustom gnus-article-time-format "%a, %b %d %Y %T %Z" | 301 | (defcustom gnus-article-time-format "%a, %b %d %Y %T %Z" |
| 266 | "Format for display of Date headers in article bodies. | 302 | "Format for display of Date headers in article bodies. |
| 267 | See `format-time-string' for the possible values. | 303 | See `format-time-string' for the possible values. |
| @@ -274,8 +310,6 @@ be fed to `format-time-string'." | |||
| 274 | :group 'gnus-article-washing) | 310 | :group 'gnus-article-washing) |
| 275 | 311 | ||
| 276 | (eval-and-compile | 312 | (eval-and-compile |
| 277 | (autoload 'hexl-hex-string-to-integer "hexl") | ||
| 278 | (autoload 'timezone-make-date-arpa-standard "timezone") | ||
| 279 | (autoload 'mail-extract-address-components "mail-extr")) | 313 | (autoload 'mail-extract-address-components "mail-extr")) |
| 280 | 314 | ||
| 281 | (defcustom gnus-save-all-headers t | 315 | (defcustom gnus-save-all-headers t |
| @@ -377,34 +411,6 @@ be used as possible file names." | |||
| 377 | (cons :value ("" "") regexp (repeat string)) | 411 | (cons :value ("" "") regexp (repeat string)) |
| 378 | (sexp :value nil)))) | 412 | (sexp :value nil)))) |
| 379 | 413 | ||
| 380 | (defcustom gnus-strict-mime t | ||
| 381 | "*If nil, MIME-decode even if there is no Mime-Version header." | ||
| 382 | :group 'gnus-article-mime | ||
| 383 | :type 'boolean) | ||
| 384 | |||
| 385 | (defcustom gnus-show-mime-method 'metamail-buffer | ||
| 386 | "Function to process a MIME message. | ||
| 387 | The function is called from the article buffer." | ||
| 388 | :group 'gnus-article-mime | ||
| 389 | :type 'function) | ||
| 390 | |||
| 391 | (defcustom gnus-decode-encoded-word-method 'gnus-article-de-quoted-unreadable | ||
| 392 | "*Function to decode MIME encoded words. | ||
| 393 | The function is called from the article buffer." | ||
| 394 | :group 'gnus-article-mime | ||
| 395 | :type 'function) | ||
| 396 | |||
| 397 | (defcustom gnus-show-traditional-method | ||
| 398 | (if (and (featurep 'mule) | ||
| 399 | (boundp 'enable-multibyte-characters)) | ||
| 400 | (lambda () | ||
| 401 | (if enable-multibyte-characters (gnus-mule-decode-article))) | ||
| 402 | (lambda ())) | ||
| 403 | "Function to decode ``localized RFC 822 messages''. | ||
| 404 | The function is called from the article buffer." | ||
| 405 | :group 'gnus-article-mime | ||
| 406 | :type 'function) | ||
| 407 | |||
| 408 | (defcustom gnus-page-delimiter "^\^L" | 414 | (defcustom gnus-page-delimiter "^\^L" |
| 409 | "*Regexp describing what to use as article page delimiters. | 415 | "*Regexp describing what to use as article page delimiters. |
| 410 | The default value is \"^\^L\", which is a form linefeed at the | 416 | The default value is \"^\^L\", which is a form linefeed at the |
| @@ -412,9 +418,14 @@ beginning of a line." | |||
| 412 | :type 'regexp | 418 | :type 'regexp |
| 413 | :group 'gnus-article-various) | 419 | :group 'gnus-article-various) |
| 414 | 420 | ||
| 415 | (defcustom gnus-article-mode-line-format "Gnus: %%b %S" | 421 | (defcustom gnus-article-mode-line-format "Gnus: %g [%w] %S%m" |
| 416 | "*The format specification for the article mode line. | 422 | "*The format specification for the article mode line. |
| 417 | See `gnus-summary-mode-line-format' for a closer description." | 423 | See `gnus-summary-mode-line-format' for a closer description. |
| 424 | |||
| 425 | The following additional specs are available: | ||
| 426 | |||
| 427 | %w The article washing status. | ||
| 428 | %m The number of MIME parts in the article." | ||
| 418 | :type 'string | 429 | :type 'string |
| 419 | :group 'gnus-article-various) | 430 | :group 'gnus-article-various) |
| 420 | 431 | ||
| @@ -429,8 +440,7 @@ See `gnus-summary-mode-line-format' for a closer description." | |||
| 429 | :group 'gnus-article-various) | 440 | :group 'gnus-article-various) |
| 430 | 441 | ||
| 431 | (defcustom gnus-article-prepare-hook nil | 442 | (defcustom gnus-article-prepare-hook nil |
| 432 | "*A hook called after an article has been prepared in the article buffer. | 443 | "*A hook called after an article has been prepared in the article buffer." |
| 433 | If you want to run a special decoding program like nkf, use this hook." | ||
| 434 | :type 'hook | 444 | :type 'hook |
| 435 | :group 'gnus-article-various) | 445 | :group 'gnus-article-various) |
| 436 | 446 | ||
| @@ -559,8 +569,413 @@ displayed by the first non-nil matching CONTENT face." | |||
| 559 | (item :tag "skip" nil) | 569 | (item :tag "skip" nil) |
| 560 | (face :value default))))) | 570 | (face :value default))))) |
| 561 | 571 | ||
| 572 | (defcustom gnus-article-decode-hook | ||
| 573 | '(article-decode-charset article-decode-encoded-words) | ||
| 574 | "*Hook run to decode charsets in articles." | ||
| 575 | :group 'gnus-article-headers | ||
| 576 | :type 'hook) | ||
| 577 | |||
| 578 | (defcustom gnus-display-mime-function 'gnus-display-mime | ||
| 579 | "Function to display MIME articles." | ||
| 580 | :group 'gnus-article-mime | ||
| 581 | :type 'function) | ||
| 582 | |||
| 583 | (defvar gnus-decode-header-function 'mail-decode-encoded-word-region | ||
| 584 | "Function used to decode headers.") | ||
| 585 | |||
| 586 | (defvar gnus-article-dumbquotes-map | ||
| 587 | '(("\202" ",") | ||
| 588 | ("\203" "f") | ||
| 589 | ("\204" ",,") | ||
| 590 | ("\205" "...") | ||
| 591 | ("\213" "<") | ||
| 592 | ("\214" "OE") | ||
| 593 | ("\221" "`") | ||
| 594 | ("\222" "'") | ||
| 595 | ("\223" "``") | ||
| 596 | ("\224" "\"") | ||
| 597 | ("\225" "*") | ||
| 598 | ("\226" "---") | ||
| 599 | ("\227" "-") | ||
| 600 | ("\231" "(TM)") | ||
| 601 | ("\233" ">") | ||
| 602 | ("\234" "oe") | ||
| 603 | ("\264" "'")) | ||
| 604 | "Table for MS-to-Latin1 translation.") | ||
| 605 | |||
| 606 | (defcustom gnus-ignored-mime-types nil | ||
| 607 | "List of MIME types that should be ignored by Gnus." | ||
| 608 | :group 'gnus-article-mime | ||
| 609 | :type '(repeat regexp)) | ||
| 610 | |||
| 611 | (defcustom gnus-unbuttonized-mime-types '(".*/.*") | ||
| 612 | "List of MIME types that should not be given buttons when rendered inline." | ||
| 613 | :group 'gnus-article-mime | ||
| 614 | :type '(repeat regexp)) | ||
| 615 | |||
| 616 | (defcustom gnus-article-mime-part-function nil | ||
| 617 | "Function called with a MIME handle as the argument. | ||
| 618 | This is meant for people who want to do something automatic based | ||
| 619 | on parts -- for instance, adding Vcard info to a database." | ||
| 620 | :group 'gnus-article-mime | ||
| 621 | :type 'function) | ||
| 622 | |||
| 623 | (defcustom gnus-mime-multipart-functions nil | ||
| 624 | "An alist of MIME types to functions to display them.") | ||
| 625 | |||
| 626 | (defcustom gnus-article-date-lapsed-new-header nil | ||
| 627 | "Whether the X-Sent and Date headers can coexist. | ||
| 628 | When using `gnus-treat-date-lapsed', the \"X-Sent:\" header will | ||
| 629 | either replace the old \"Date:\" header (if this variable is nil), or | ||
| 630 | be added below it (otherwise)." | ||
| 631 | :group 'gnus-article-headers | ||
| 632 | :type 'boolean) | ||
| 633 | |||
| 634 | (defcustom gnus-article-mime-match-handle-function 'undisplayed-alternative | ||
| 635 | "Function called with a MIME handle as the argument. | ||
| 636 | This is meant for people who want to view first matched part. | ||
| 637 | For `undisplayed-alternative' (default), the first undisplayed | ||
| 638 | part or alternative part is used. For `undisplayed', the first | ||
| 639 | undisplayed part is used. For a function, the first part which | ||
| 640 | the function return `t' is used. For `nil', the first part is | ||
| 641 | used." | ||
| 642 | :group 'gnus-article-mime | ||
| 643 | :type '(choice | ||
| 644 | (item :tag "first" :value nil) | ||
| 645 | (item :tag "undisplayed" :value undisplayed) | ||
| 646 | (item :tag "undisplayed or alternative" | ||
| 647 | :value undisplayed-alternative) | ||
| 648 | (function))) | ||
| 649 | |||
| 650 | ;;; | ||
| 651 | ;;; The treatment variables | ||
| 652 | ;;; | ||
| 653 | |||
| 654 | (defvar gnus-part-display-hook nil | ||
| 655 | "Hook called on parts that are to receive treatment.") | ||
| 656 | |||
| 657 | (defvar gnus-article-treat-custom | ||
| 658 | '(choice (const :tag "Off" nil) | ||
| 659 | (const :tag "On" t) | ||
| 660 | (const :tag "Header" head) | ||
| 661 | (const :tag "Last" last) | ||
| 662 | (integer :tag "Less") | ||
| 663 | (repeat :tag "Groups" regexp) | ||
| 664 | (sexp :tag "Predicate"))) | ||
| 665 | |||
| 666 | (defvar gnus-article-treat-head-custom | ||
| 667 | '(choice (const :tag "Off" nil) | ||
| 668 | (const :tag "Header" head))) | ||
| 669 | |||
| 670 | (defvar gnus-article-treat-types '("text/plain") | ||
| 671 | "Parts to treat.") | ||
| 672 | |||
| 673 | (defvar gnus-inhibit-treatment nil | ||
| 674 | "Whether to inhibit treatment.") | ||
| 675 | |||
| 676 | (defcustom gnus-treat-highlight-signature '(or last (typep "text/x-vcard")) | ||
| 677 | "Highlight the signature. | ||
| 678 | Valid values are nil, t, `head', `last', an integer or a predicate. | ||
| 679 | See the manual for details." | ||
| 680 | :group 'gnus-article-treat | ||
| 681 | :type gnus-article-treat-custom) | ||
| 682 | (put 'gnus-treat-highlight-signature 'highlight t) | ||
| 683 | |||
| 684 | (defcustom gnus-treat-buttonize 100000 | ||
| 685 | "Add buttons. | ||
| 686 | Valid values are nil, t, `head', `last', an integer or a predicate. | ||
| 687 | See the manual for details." | ||
| 688 | :group 'gnus-article-treat | ||
| 689 | :type gnus-article-treat-custom) | ||
| 690 | (put 'gnus-treat-buttonize 'highlight t) | ||
| 691 | |||
| 692 | (defcustom gnus-treat-buttonize-head 'head | ||
| 693 | "Add buttons to the head. | ||
| 694 | Valid values are nil, t, `head', `last', an integer or a predicate. | ||
| 695 | See the manual for details." | ||
| 696 | :group 'gnus-article-treat | ||
| 697 | :type gnus-article-treat-head-custom) | ||
| 698 | (put 'gnus-treat-buttonize-head 'highlight t) | ||
| 699 | |||
| 700 | (defcustom gnus-treat-emphasize 50000 | ||
| 701 | "Emphasize text. | ||
| 702 | Valid values are nil, t, `head', `last', an integer or a predicate. | ||
| 703 | See the manual for details." | ||
| 704 | :group 'gnus-article-treat | ||
| 705 | :type gnus-article-treat-custom) | ||
| 706 | (put 'gnus-treat-emphasize 'highlight t) | ||
| 707 | |||
| 708 | (defcustom gnus-treat-strip-cr nil | ||
| 709 | "Remove carriage returns. | ||
| 710 | Valid values are nil, t, `head', `last', an integer or a predicate. | ||
| 711 | See the manual for details." | ||
| 712 | :group 'gnus-article-treat | ||
| 713 | :type gnus-article-treat-custom) | ||
| 714 | |||
| 715 | (defcustom gnus-treat-hide-headers 'head | ||
| 716 | "Hide headers. | ||
| 717 | Valid values are nil, t, `head', `last', an integer or a predicate. | ||
| 718 | See the manual for details." | ||
| 719 | :group 'gnus-article-treat | ||
| 720 | :type gnus-article-treat-head-custom) | ||
| 721 | |||
| 722 | (defcustom gnus-treat-hide-boring-headers nil | ||
| 723 | "Hide boring headers. | ||
| 724 | Valid values are nil, t, `head', `last', an integer or a predicate. | ||
| 725 | See the manual for details." | ||
| 726 | :group 'gnus-article-treat | ||
| 727 | :type gnus-article-treat-head-custom) | ||
| 728 | |||
| 729 | (defcustom gnus-treat-hide-signature nil | ||
| 730 | "Hide the signature. | ||
| 731 | Valid values are nil, t, `head', `last', an integer or a predicate. | ||
| 732 | See the manual for details." | ||
| 733 | :group 'gnus-article-treat | ||
| 734 | :type gnus-article-treat-custom) | ||
| 735 | |||
| 736 | (defcustom gnus-treat-fill-article nil | ||
| 737 | "Fill the article. | ||
| 738 | Valid values are nil, t, `head', `last', an integer or a predicate. | ||
| 739 | See the manual for details." | ||
| 740 | :group 'gnus-article-treat | ||
| 741 | :type gnus-article-treat-custom) | ||
| 742 | |||
| 743 | (defcustom gnus-treat-hide-citation nil | ||
| 744 | "Hide cited text. | ||
| 745 | Valid values are nil, t, `head', `last', an integer or a predicate. | ||
| 746 | See the manual for details." | ||
| 747 | :group 'gnus-article-treat | ||
| 748 | :type gnus-article-treat-custom) | ||
| 749 | |||
| 750 | (defcustom gnus-treat-strip-list-identifiers 'head | ||
| 751 | "Strip list identifiers from `gnus-list-identifiers`. | ||
| 752 | Valid values are nil, t, `head', `last', an integer or a predicate. | ||
| 753 | See the manual for details." | ||
| 754 | :group 'gnus-article-treat | ||
| 755 | :type gnus-article-treat-custom) | ||
| 756 | |||
| 757 | (defcustom gnus-treat-strip-pgp t | ||
| 758 | "Strip PGP signatures. | ||
| 759 | Valid values are nil, t, `head', `last', an integer or a predicate. | ||
| 760 | See the manual for details." | ||
| 761 | :group 'gnus-article-treat | ||
| 762 | :type gnus-article-treat-custom) | ||
| 763 | |||
| 764 | (defcustom gnus-treat-strip-pem nil | ||
| 765 | "Strip PEM signatures. | ||
| 766 | Valid values are nil, t, `head', `last', an integer or a predicate. | ||
| 767 | See the manual for details." | ||
| 768 | :group 'gnus-article-treat | ||
| 769 | :type gnus-article-treat-custom) | ||
| 770 | |||
| 771 | (defcustom gnus-treat-strip-banner t | ||
| 772 | "Strip banners from articles. | ||
| 773 | The banner to be stripped is specified in the `banner' group parameter. | ||
| 774 | Valid values are nil, t, `head', `last', an integer or a predicate. | ||
| 775 | See the manual for details." | ||
| 776 | :group 'gnus-article-treat | ||
| 777 | :type gnus-article-treat-custom) | ||
| 778 | |||
| 779 | (defcustom gnus-treat-highlight-headers 'head | ||
| 780 | "Highlight the headers. | ||
| 781 | Valid values are nil, t, `head', `last', an integer or a predicate. | ||
| 782 | See the manual for details." | ||
| 783 | :group 'gnus-article-treat | ||
| 784 | :type gnus-article-treat-head-custom) | ||
| 785 | (put 'gnus-treat-highlight-headers 'highlight t) | ||
| 786 | |||
| 787 | (defcustom gnus-treat-highlight-citation t | ||
| 788 | "Highlight cited text. | ||
| 789 | Valid values are nil, t, `head', `last', an integer or a predicate. | ||
| 790 | See the manual for details." | ||
| 791 | :group 'gnus-article-treat | ||
| 792 | :type gnus-article-treat-custom) | ||
| 793 | (put 'gnus-treat-highlight-citation 'highlight t) | ||
| 794 | |||
| 795 | (defcustom gnus-treat-date-ut nil | ||
| 796 | "Display the Date in UT (GMT). | ||
| 797 | Valid values are nil, t, `head', `last', an integer or a predicate. | ||
| 798 | See the manual for details." | ||
| 799 | :group 'gnus-article-treat | ||
| 800 | :type gnus-article-treat-head-custom) | ||
| 801 | |||
| 802 | (defcustom gnus-treat-date-local nil | ||
| 803 | "Display the Date in the local timezone. | ||
| 804 | Valid values are nil, t, `head', `last', an integer or a predicate. | ||
| 805 | See the manual for details." | ||
| 806 | :group 'gnus-article-treat | ||
| 807 | :type gnus-article-treat-head-custom) | ||
| 808 | |||
| 809 | (defcustom gnus-treat-date-lapsed nil | ||
| 810 | "Display the Date header in a way that says how much time has elapsed. | ||
| 811 | Valid values are nil, t, `head', `last', an integer or a predicate. | ||
| 812 | See the manual for details." | ||
| 813 | :group 'gnus-article-treat | ||
| 814 | :type gnus-article-treat-head-custom) | ||
| 815 | |||
| 816 | (defcustom gnus-treat-date-original nil | ||
| 817 | "Display the date in the original timezone. | ||
| 818 | Valid values are nil, t, `head', `last', an integer or a predicate. | ||
| 819 | See the manual for details." | ||
| 820 | :group 'gnus-article-treat | ||
| 821 | :type gnus-article-treat-head-custom) | ||
| 822 | |||
| 823 | (defcustom gnus-treat-date-iso8601 nil | ||
| 824 | "Display the date in the ISO8601 format. | ||
| 825 | Valid values are nil, t, `head', `last', an integer or a predicate. | ||
| 826 | See the manual for details." | ||
| 827 | :group 'gnus-article-treat | ||
| 828 | :type gnus-article-treat-head-custom) | ||
| 829 | |||
| 830 | (defcustom gnus-treat-date-user-defined nil | ||
| 831 | "Display the date in a user-defined format. | ||
| 832 | The format is defined by the `gnus-article-time-format' variable. | ||
| 833 | Valid values are nil, t, `head', `last', an integer or a predicate. | ||
| 834 | See the manual for details." | ||
| 835 | :group 'gnus-article-treat | ||
| 836 | :type gnus-article-treat-head-custom) | ||
| 837 | |||
| 838 | (defcustom gnus-treat-strip-headers-in-body t | ||
| 839 | "Strip the X-No-Archive header line from the beginning of the body. | ||
| 840 | Valid values are nil, t, `head', `last', an integer or a predicate. | ||
| 841 | See the manual for details." | ||
| 842 | :group 'gnus-article-treat | ||
| 843 | :type gnus-article-treat-custom) | ||
| 844 | |||
| 845 | (defcustom gnus-treat-strip-trailing-blank-lines nil | ||
| 846 | "Strip trailing blank lines. | ||
| 847 | Valid values are nil, t, `head', `last', an integer or a predicate. | ||
| 848 | See the manual for details." | ||
| 849 | :group 'gnus-article-treat | ||
| 850 | :type gnus-article-treat-custom) | ||
| 851 | |||
| 852 | (defcustom gnus-treat-strip-leading-blank-lines nil | ||
| 853 | "Strip leading blank lines. | ||
| 854 | Valid values are nil, t, `head', `last', an integer or a predicate. | ||
| 855 | See the manual for details." | ||
| 856 | :group 'gnus-article-treat | ||
| 857 | :type gnus-article-treat-custom) | ||
| 858 | |||
| 859 | (defcustom gnus-treat-strip-multiple-blank-lines nil | ||
| 860 | "Strip multiple blank lines. | ||
| 861 | Valid values are nil, t, `head', `last', an integer or a predicate. | ||
| 862 | See the manual for details." | ||
| 863 | :group 'gnus-article-treat | ||
| 864 | :type gnus-article-treat-custom) | ||
| 865 | |||
| 866 | (defcustom gnus-treat-overstrike t | ||
| 867 | "Treat overstrike highlighting. | ||
| 868 | Valid values are nil, t, `head', `last', an integer or a predicate. | ||
| 869 | See the manual for details." | ||
| 870 | :group 'gnus-article-treat | ||
| 871 | :type gnus-article-treat-custom) | ||
| 872 | (put 'gnus-treat-overstrike 'highlight t) | ||
| 873 | |||
| 874 | (defcustom gnus-treat-display-xface | ||
| 875 | (and (or (and (fboundp 'image-type-available-p) | ||
| 876 | (image-type-available-p 'xbm)) | ||
| 877 | (and gnus-xemacs (featurep 'xface))) | ||
| 878 | 'head) | ||
| 879 | "Display X-Face headers. | ||
| 880 | Valid values are nil, t, `head', `last', an integer or a predicate. | ||
| 881 | See the manual for details." | ||
| 882 | :group 'gnus-article-treat | ||
| 883 | :type gnus-article-treat-head-custom) | ||
| 884 | (put 'gnus-treat-display-xface 'highlight t) | ||
| 885 | |||
| 886 | (defcustom gnus-treat-display-smileys (if (and gnus-xemacs | ||
| 887 | (featurep 'xpm)) | ||
| 888 | t nil) | ||
| 889 | "Display smileys. | ||
| 890 | Valid values are nil, t, `head', `last', an integer or a predicate. | ||
| 891 | See the manual for details." | ||
| 892 | :group 'gnus-article-treat | ||
| 893 | :type gnus-article-treat-custom) | ||
| 894 | (put 'gnus-treat-display-smileys 'highlight t) | ||
| 895 | |||
| 896 | (defcustom gnus-treat-display-picons (if gnus-xemacs 'head nil) | ||
| 897 | "Display picons. | ||
| 898 | Valid values are nil, t, `head', `last', an integer or a predicate. | ||
| 899 | See the manual for details." | ||
| 900 | :group 'gnus-article-treat | ||
| 901 | :type gnus-article-treat-head-custom) | ||
| 902 | (put 'gnus-treat-display-picons 'highlight t) | ||
| 903 | |||
| 904 | (defcustom gnus-treat-capitalize-sentences nil | ||
| 905 | "Capitalize sentence-starting words. | ||
| 906 | Valid values are nil, t, `head', `last', an integer or a predicate. | ||
| 907 | See the manual for details." | ||
| 908 | :group 'gnus-article-treat | ||
| 909 | :type gnus-article-treat-custom) | ||
| 910 | |||
| 911 | (defcustom gnus-treat-fill-long-lines nil | ||
| 912 | "Fill long lines. | ||
| 913 | Valid values are nil, t, `head', `last', an integer or a predicate. | ||
| 914 | See the manual for details." | ||
| 915 | :group 'gnus-article-treat | ||
| 916 | :type gnus-article-treat-custom) | ||
| 917 | |||
| 918 | (defcustom gnus-treat-play-sounds nil | ||
| 919 | "Play sounds. | ||
| 920 | Valid values are nil, t, `head', `last', an integer or a predicate. | ||
| 921 | See the manual for details." | ||
| 922 | :group 'gnus-article-treat | ||
| 923 | :type gnus-article-treat-custom) | ||
| 924 | |||
| 925 | (defcustom gnus-treat-translate nil | ||
| 926 | "Translate articles from one language to another. | ||
| 927 | Valid values are nil, t, `head', `last', an integer or a predicate. | ||
| 928 | See the manual for details." | ||
| 929 | :group 'gnus-article-treat | ||
| 930 | :type gnus-article-treat-custom) | ||
| 931 | |||
| 562 | ;;; Internal variables | 932 | ;;; Internal variables |
| 563 | 933 | ||
| 934 | (defvar article-goto-body-goes-to-point-min-p nil) | ||
| 935 | (defvar gnus-article-wash-types nil) | ||
| 936 | (defvar gnus-article-emphasis-alist nil) | ||
| 937 | |||
| 938 | (defvar gnus-article-mime-handle-alist-1 nil) | ||
| 939 | (defvar gnus-treatment-function-alist | ||
| 940 | '((gnus-treat-strip-banner gnus-article-strip-banner) | ||
| 941 | (gnus-treat-strip-headers-in-body gnus-article-strip-headers-in-body) | ||
| 942 | (gnus-treat-highlight-signature gnus-article-highlight-signature) | ||
| 943 | (gnus-treat-buttonize gnus-article-add-buttons) | ||
| 944 | (gnus-treat-fill-article gnus-article-fill-cited-article) | ||
| 945 | (gnus-treat-fill-long-lines gnus-article-fill-long-lines) | ||
| 946 | (gnus-treat-strip-cr gnus-article-remove-cr) | ||
| 947 | (gnus-treat-emphasize gnus-article-emphasize) | ||
| 948 | (gnus-treat-display-xface gnus-article-display-x-face) | ||
| 949 | (gnus-treat-hide-headers gnus-article-maybe-hide-headers) | ||
| 950 | (gnus-treat-hide-boring-headers gnus-article-hide-boring-headers) | ||
| 951 | (gnus-treat-hide-signature gnus-article-hide-signature) | ||
| 952 | (gnus-treat-hide-citation gnus-article-hide-citation) | ||
| 953 | (gnus-treat-strip-list-identifiers gnus-article-hide-list-identifiers) | ||
| 954 | (gnus-treat-strip-pgp gnus-article-hide-pgp) | ||
| 955 | (gnus-treat-strip-pem gnus-article-hide-pem) | ||
| 956 | (gnus-treat-highlight-headers gnus-article-highlight-headers) | ||
| 957 | (gnus-treat-highlight-citation gnus-article-highlight-citation) | ||
| 958 | (gnus-treat-highlight-signature gnus-article-highlight-signature) | ||
| 959 | (gnus-treat-date-ut gnus-article-date-ut) | ||
| 960 | (gnus-treat-date-local gnus-article-date-local) | ||
| 961 | (gnus-treat-date-lapsed gnus-article-date-lapsed) | ||
| 962 | (gnus-treat-date-original gnus-article-date-original) | ||
| 963 | (gnus-treat-date-user-defined gnus-article-date-user) | ||
| 964 | (gnus-treat-date-iso8601 gnus-article-date-iso8601) | ||
| 965 | (gnus-treat-strip-trailing-blank-lines | ||
| 966 | gnus-article-remove-trailing-blank-lines) | ||
| 967 | (gnus-treat-strip-leading-blank-lines | ||
| 968 | gnus-article-strip-leading-blank-lines) | ||
| 969 | (gnus-treat-strip-multiple-blank-lines | ||
| 970 | gnus-article-strip-multiple-blank-lines) | ||
| 971 | (gnus-treat-overstrike gnus-article-treat-overstrike) | ||
| 972 | (gnus-treat-buttonize-head gnus-article-add-buttons-to-head) | ||
| 973 | (gnus-treat-display-smileys gnus-smiley-display) | ||
| 974 | (gnus-treat-capitalize-sentences gnus-article-capitalize-sentences) | ||
| 975 | (gnus-treat-display-picons gnus-article-display-picons) | ||
| 976 | (gnus-treat-play-sounds gnus-earcon-display))) | ||
| 977 | |||
| 978 | (defvar gnus-article-mime-handle-alist nil) | ||
| 564 | (defvar article-lapsed-timer nil) | 979 | (defvar article-lapsed-timer nil) |
| 565 | (defvar gnus-article-current-summary nil) | 980 | (defvar gnus-article-current-summary nil) |
| 566 | 981 | ||
| @@ -576,7 +991,8 @@ Initialized from `text-mode-syntax-table.") | |||
| 576 | (defvar gnus-save-article-buffer nil) | 991 | (defvar gnus-save-article-buffer nil) |
| 577 | 992 | ||
| 578 | (defvar gnus-article-mode-line-format-alist | 993 | (defvar gnus-article-mode-line-format-alist |
| 579 | (nconc '((?w (gnus-article-wash-status) ?s)) | 994 | (nconc '((?w (gnus-article-wash-status) ?s) |
| 995 | (?m (gnus-article-mime-part-status) ?s)) | ||
| 580 | gnus-summary-mode-line-format-alist)) | 996 | gnus-summary-mode-line-format-alist)) |
| 581 | 997 | ||
| 582 | (defvar gnus-number-of-articles-to-be-saved nil) | 998 | (defvar gnus-number-of-articles-to-be-saved nil) |
| @@ -590,7 +1006,6 @@ Initialized from `text-mode-syntax-table.") | |||
| 590 | (put-text-property | 1006 | (put-text-property |
| 591 | (max (1- b) (point-min)) | 1007 | (max (1- b) (point-min)) |
| 592 | b 'intangible (cddr (memq 'intangible props))))) | 1008 | b 'intangible (cddr (memq 'intangible props))))) |
| 593 | |||
| 594 | (defsubst gnus-article-unhide-text (b e) | 1009 | (defsubst gnus-article-unhide-text (b e) |
| 595 | "Remove hidden text properties from region between B and E." | 1010 | "Remove hidden text properties from region between B and E." |
| 596 | (remove-text-properties b e gnus-hidden-properties) | 1011 | (remove-text-properties b e gnus-hidden-properties) |
| @@ -600,11 +1015,14 @@ Initialized from `text-mode-syntax-table.") | |||
| 600 | 1015 | ||
| 601 | (defun gnus-article-hide-text-type (b e type) | 1016 | (defun gnus-article-hide-text-type (b e type) |
| 602 | "Hide text of TYPE between B and E." | 1017 | "Hide text of TYPE between B and E." |
| 1018 | (push type gnus-article-wash-types) | ||
| 603 | (gnus-article-hide-text | 1019 | (gnus-article-hide-text |
| 604 | b e (cons 'article-type (cons type gnus-hidden-properties)))) | 1020 | b e (cons 'article-type (cons type gnus-hidden-properties)))) |
| 605 | 1021 | ||
| 606 | (defun gnus-article-unhide-text-type (b e type) | 1022 | (defun gnus-article-unhide-text-type (b e type) |
| 607 | "Unhide text of TYPE between B and E." | 1023 | "Unhide text of TYPE between B and E." |
| 1024 | (setq gnus-article-wash-types | ||
| 1025 | (delq type gnus-article-wash-types)) | ||
| 608 | (remove-text-properties | 1026 | (remove-text-properties |
| 609 | b e (cons 'article-type (cons type gnus-hidden-properties))) | 1027 | b e (cons 'article-type (cons type gnus-hidden-properties))) |
| 610 | (when (memq 'intangible gnus-hidden-properties) | 1028 | (when (memq 'intangible gnus-hidden-properties) |
| @@ -653,79 +1071,60 @@ Initialized from `text-mode-syntax-table.") | |||
| 653 | i)) | 1071 | i)) |
| 654 | 1072 | ||
| 655 | (defun article-hide-headers (&optional arg delete) | 1073 | (defun article-hide-headers (&optional arg delete) |
| 656 | "Toggle whether to hide unwanted headers and possibly sort them as well. | 1074 | "Hide unwanted headers and possibly sort them as well." |
| 657 | If given a negative prefix, always show; if given a positive prefix, | 1075 | (interactive) |
| 658 | always hide." | 1076 | ;; This function might be inhibited. |
| 659 | (interactive (gnus-article-hidden-arg)) | 1077 | (unless gnus-inhibit-hiding |
| 660 | (current-buffer) | 1078 | (save-excursion |
| 661 | (if (gnus-article-check-hidden-text 'headers arg) | 1079 | (save-restriction |
| 662 | ;; Show boring headers as well. | 1080 | (let ((buffer-read-only nil) |
| 663 | (gnus-article-show-hidden-text 'boring-headers) | 1081 | (case-fold-search t) |
| 664 | ;; This function might be inhibited. | 1082 | (max (1+ (length gnus-sorted-header-list))) |
| 665 | (unless gnus-inhibit-hiding | 1083 | (ignored (when (not gnus-visible-headers) |
| 666 | (save-excursion | 1084 | (cond ((stringp gnus-ignored-headers) |
| 667 | (save-restriction | 1085 | gnus-ignored-headers) |
| 668 | (let ((buffer-read-only nil) | 1086 | ((listp gnus-ignored-headers) |
| 669 | (case-fold-search t) | 1087 | (mapconcat 'identity gnus-ignored-headers |
| 670 | (props (nconc (list 'article-type 'headers) | 1088 | "\\|"))))) |
| 671 | gnus-hidden-properties)) | 1089 | (visible |
| 672 | (max (1+ (length gnus-sorted-header-list))) | 1090 | (cond ((stringp gnus-visible-headers) |
| 673 | (ignored (when (not gnus-visible-headers) | 1091 | gnus-visible-headers) |
| 674 | (cond ((stringp gnus-ignored-headers) | 1092 | ((and gnus-visible-headers |
| 675 | gnus-ignored-headers) | 1093 | (listp gnus-visible-headers)) |
| 676 | ((listp gnus-ignored-headers) | 1094 | (mapconcat 'identity gnus-visible-headers "\\|")))) |
| 677 | (mapconcat 'identity gnus-ignored-headers | 1095 | (inhibit-point-motion-hooks t) |
| 678 | "\\|"))))) | 1096 | beg) |
| 679 | (visible | 1097 | ;; First we narrow to just the headers. |
| 680 | (cond ((stringp gnus-visible-headers) | 1098 | (article-narrow-to-head) |
| 681 | gnus-visible-headers) | 1099 | ;; Hide any "From " lines at the beginning of (mail) articles. |
| 682 | ((and gnus-visible-headers | 1100 | (while (looking-at "From ") |
| 683 | (listp gnus-visible-headers)) | 1101 | (forward-line 1)) |
| 684 | (mapconcat 'identity gnus-visible-headers "\\|")))) | 1102 | (unless (bobp) |
| 685 | (inhibit-point-motion-hooks t) | 1103 | (delete-region (point-min) (point))) |
| 686 | beg) | 1104 | ;; Then treat the rest of the header lines. |
| 687 | ;; First we narrow to just the headers. | 1105 | ;; Then we use the two regular expressions |
| 688 | (widen) | 1106 | ;; `gnus-ignored-headers' and `gnus-visible-headers' to |
| 689 | (goto-char (point-min)) | 1107 | ;; select which header lines is to remain visible in the |
| 690 | ;; Hide any "From " lines at the beginning of (mail) articles. | 1108 | ;; article buffer. |
| 691 | (while (looking-at "From ") | 1109 | (while (re-search-forward "^[^ \t]*:" nil t) |
| 692 | (forward-line 1)) | 1110 | (beginning-of-line) |
| 693 | (unless (bobp) | 1111 | ;; Mark the rank of the header. |
| 694 | (if delete | 1112 | (put-text-property |
| 695 | (delete-region (point-min) (point)) | 1113 | (point) (1+ (point)) 'message-rank |
| 696 | (gnus-article-hide-text (point-min) (point) props))) | 1114 | (if (or (and visible (looking-at visible)) |
| 697 | ;; Then treat the rest of the header lines. | 1115 | (and ignored |
| 698 | (narrow-to-region | 1116 | (not (looking-at ignored)))) |
| 699 | (point) | 1117 | (gnus-article-header-rank) |
| 700 | (if (search-forward "\n\n" nil t) ; if there's a body | 1118 | (+ 2 max))) |
| 701 | (progn (forward-line -1) (point)) | 1119 | (forward-line 1)) |
| 702 | (point-max))) | 1120 | (message-sort-headers-1) |
| 703 | ;; Then we use the two regular expressions | 1121 | (when (setq beg (text-property-any |
| 704 | ;; `gnus-ignored-headers' and `gnus-visible-headers' to | 1122 | (point-min) (point-max) 'message-rank (+ 2 max))) |
| 705 | ;; select which header lines is to remain visible in the | 1123 | ;; We delete the unwanted headers. |
| 706 | ;; article buffer. | 1124 | (push 'headers gnus-article-wash-types) |
| 707 | (goto-char (point-min)) | 1125 | (add-text-properties (point-min) (+ 5 (point-min)) |
| 708 | (while (re-search-forward "^[^ \t]*:" nil t) | 1126 | '(article-type headers dummy-invisible t)) |
| 709 | (beginning-of-line) | 1127 | (delete-region beg (point-max)))))))) |
| 710 | ;; Mark the rank of the header. | ||
| 711 | (put-text-property | ||
| 712 | (point) (1+ (point)) 'message-rank | ||
| 713 | (if (or (and visible (looking-at visible)) | ||
| 714 | (and ignored | ||
| 715 | (not (looking-at ignored)))) | ||
| 716 | (gnus-article-header-rank) | ||
| 717 | (+ 2 max))) | ||
| 718 | (forward-line 1)) | ||
| 719 | (message-sort-headers-1) | ||
| 720 | (when (setq beg (text-property-any | ||
| 721 | (point-min) (point-max) 'message-rank (+ 2 max))) | ||
| 722 | ;; We make the unwanted headers invisible. | ||
| 723 | (if delete | ||
| 724 | (delete-region beg (point-max)) | ||
| 725 | ;; Suggested by Sudish Joseph <joseph@cis.ohio-state.edu>. | ||
| 726 | (gnus-article-hide-text-type beg (point-max) 'headers)) | ||
| 727 | ;; Work around XEmacs lossage. | ||
| 728 | (put-text-property (point-min) beg 'invisible nil)))))))) | ||
| 729 | 1128 | ||
| 730 | (defun article-hide-boring-headers (&optional arg) | 1129 | (defun article-hide-boring-headers (&optional arg) |
| 731 | "Toggle hiding of headers that aren't very interesting. | 1130 | "Toggle hiding of headers that aren't very interesting. |
| @@ -740,14 +1139,14 @@ always hide." | |||
| 740 | (list gnus-boring-article-headers) | 1139 | (list gnus-boring-article-headers) |
| 741 | (inhibit-point-motion-hooks t) | 1140 | (inhibit-point-motion-hooks t) |
| 742 | elem) | 1141 | elem) |
| 743 | (nnheader-narrow-to-headers) | 1142 | (article-narrow-to-head) |
| 744 | (while list | 1143 | (while list |
| 745 | (setq elem (pop list)) | 1144 | (setq elem (pop list)) |
| 746 | (goto-char (point-min)) | 1145 | (goto-char (point-min)) |
| 747 | (cond | 1146 | (cond |
| 748 | ;; Hide empty headers. | 1147 | ;; Hide empty headers. |
| 749 | ((eq elem 'empty) | 1148 | ((eq elem 'empty) |
| 750 | (while (re-search-forward "^[^:]+:[ \t]*\n[^ \t]" nil t) | 1149 | (while (re-search-forward "^[^: \t]+:[ \t]*\n[^ \t]" nil t) |
| 751 | (forward-line -1) | 1150 | (forward-line -1) |
| 752 | (gnus-article-hide-text-type | 1151 | (gnus-article-hide-text-type |
| 753 | (progn (beginning-of-line) (point)) | 1152 | (progn (beginning-of-line) (point)) |
| @@ -782,15 +1181,19 @@ always hide." | |||
| 782 | ((eq elem 'date) | 1181 | ((eq elem 'date) |
| 783 | (let ((date (message-fetch-field "date"))) | 1182 | (let ((date (message-fetch-field "date"))) |
| 784 | (when (and date | 1183 | (when (and date |
| 785 | (< (gnus-days-between (current-time-string) date) | 1184 | (< (days-between (current-time-string) date) |
| 786 | 4)) | 1185 | 4)) |
| 787 | (gnus-article-hide-header "date")))) | 1186 | (gnus-article-hide-header "date")))) |
| 788 | ((eq elem 'long-to) | 1187 | ((eq elem 'long-to) |
| 789 | (let ((to (message-fetch-field "to"))) | 1188 | (let ((to (message-fetch-field "to")) |
| 1189 | (cc (message-fetch-field "cc"))) | ||
| 790 | (when (> (length to) 1024) | 1190 | (when (> (length to) 1024) |
| 791 | (gnus-article-hide-header "to")))) | 1191 | (gnus-article-hide-header "to")) |
| 1192 | (when (> (length cc) 1024) | ||
| 1193 | (gnus-article-hide-header "cc")))) | ||
| 792 | ((eq elem 'many-to) | 1194 | ((eq elem 'many-to) |
| 793 | (let ((to-count 0)) | 1195 | (let ((to-count 0) |
| 1196 | (cc-count 0)) | ||
| 794 | (goto-char (point-min)) | 1197 | (goto-char (point-min)) |
| 795 | (while (re-search-forward "^to:" nil t) | 1198 | (while (re-search-forward "^to:" nil t) |
| 796 | (setq to-count (1+ to-count))) | 1199 | (setq to-count (1+ to-count))) |
| @@ -802,7 +1205,19 @@ always hide." | |||
| 802 | (forward-line -1) | 1205 | (forward-line -1) |
| 803 | (narrow-to-region (point) (point-max)) | 1206 | (narrow-to-region (point) (point-max)) |
| 804 | (gnus-article-hide-header "to")) | 1207 | (gnus-article-hide-header "to")) |
| 805 | (setq to-count (1- to-count))))))))))))) | 1208 | (setq to-count (1- to-count)))) |
| 1209 | (goto-char (point-min)) | ||
| 1210 | (while (re-search-forward "^cc:" nil t) | ||
| 1211 | (setq cc-count (1+ cc-count))) | ||
| 1212 | (when (> cc-count 1) | ||
| 1213 | (while (> cc-count 0) | ||
| 1214 | (goto-char (point-min)) | ||
| 1215 | (save-restriction | ||
| 1216 | (re-search-forward "^cc:" nil nil cc-count) | ||
| 1217 | (forward-line -1) | ||
| 1218 | (narrow-to-region (point) (point-max)) | ||
| 1219 | (gnus-article-hide-header "cc")) | ||
| 1220 | (setq cc-count (1- cc-count))))))))))))) | ||
| 806 | 1221 | ||
| 807 | (defun gnus-article-hide-header (header) | 1222 | (defun gnus-article-hide-header (header) |
| 808 | (save-excursion | 1223 | (save-excursion |
| @@ -817,18 +1232,50 @@ always hide." | |||
| 817 | (point-max))) | 1232 | (point-max))) |
| 818 | 'boring-headers)))) | 1233 | 'boring-headers)))) |
| 819 | 1234 | ||
| 1235 | (defvar gnus-article-normalized-header-length 40 | ||
| 1236 | "Length of normalized headers.") | ||
| 1237 | |||
| 1238 | (defun article-normalize-headers () | ||
| 1239 | "Make all header lines 40 characters long." | ||
| 1240 | (interactive) | ||
| 1241 | (let ((buffer-read-only nil) | ||
| 1242 | column) | ||
| 1243 | (save-excursion | ||
| 1244 | (save-restriction | ||
| 1245 | (article-narrow-to-head) | ||
| 1246 | (while (not (eobp)) | ||
| 1247 | (cond | ||
| 1248 | ((< (setq column (- (gnus-point-at-eol) (point))) | ||
| 1249 | gnus-article-normalized-header-length) | ||
| 1250 | (end-of-line) | ||
| 1251 | (insert (make-string | ||
| 1252 | (- gnus-article-normalized-header-length column) | ||
| 1253 | ? ))) | ||
| 1254 | ((> column gnus-article-normalized-header-length) | ||
| 1255 | (gnus-put-text-property | ||
| 1256 | (progn | ||
| 1257 | (forward-char gnus-article-normalized-header-length) | ||
| 1258 | (point)) | ||
| 1259 | (gnus-point-at-eol) | ||
| 1260 | 'invisible t)) | ||
| 1261 | (t | ||
| 1262 | ;; Do nothing. | ||
| 1263 | )) | ||
| 1264 | (forward-line 1)))))) | ||
| 1265 | |||
| 820 | (defun article-treat-dumbquotes () | 1266 | (defun article-treat-dumbquotes () |
| 821 | "Translate M******** sm*rtq**t*s into proper text." | 1267 | "Translate M******** sm*rtq**t*s into proper text. |
| 1268 | Note that this function guesses whether a character is a sm*rtq**t* or | ||
| 1269 | not, so it should only be used interactively." | ||
| 822 | (interactive) | 1270 | (interactive) |
| 823 | (article-translate-characters "\221\222\223\223" "`'\"\"")) | 1271 | (article-translate-strings gnus-article-dumbquotes-map)) |
| 824 | 1272 | ||
| 825 | (defun article-translate-characters (from to) | 1273 | (defun article-translate-characters (from to) |
| 826 | "Translate all characters in the body of the article according to FROM and TO. | 1274 | "Translate all characters in the body of the article according to FROM and TO. |
| 827 | FROM is a string of characters to translate from; to is a string of | 1275 | FROM is a string of characters to translate from; to is a string of |
| 828 | characters to translate to." | 1276 | characters to translate to." |
| 829 | (save-excursion | 1277 | (save-excursion |
| 830 | (goto-char (point-min)) | 1278 | (when (article-goto-body) |
| 831 | (when (search-forward "\n\n" nil t) | ||
| 832 | (let ((buffer-read-only nil) | 1279 | (let ((buffer-read-only nil) |
| 833 | (x (make-string 225 ?x)) | 1280 | (x (make-string 225 ?x)) |
| 834 | (i -1)) | 1281 | (i -1)) |
| @@ -840,15 +1287,26 @@ characters to translate to." | |||
| 840 | (incf i)) | 1287 | (incf i)) |
| 841 | (translate-region (point) (point-max) x))))) | 1288 | (translate-region (point) (point-max) x))))) |
| 842 | 1289 | ||
| 1290 | (defun article-translate-strings (map) | ||
| 1291 | "Translate all string in the body of the article according to MAP. | ||
| 1292 | MAP is an alist where the elements are on the form (\"from\" \"to\")." | ||
| 1293 | (save-excursion | ||
| 1294 | (when (article-goto-body) | ||
| 1295 | (let ((buffer-read-only nil) | ||
| 1296 | elem) | ||
| 1297 | (while (setq elem (pop map)) | ||
| 1298 | (save-excursion | ||
| 1299 | (while (search-forward (car elem) nil t) | ||
| 1300 | (replace-match (cadr elem))))))))) | ||
| 1301 | |||
| 843 | (defun article-treat-overstrike () | 1302 | (defun article-treat-overstrike () |
| 844 | "Translate overstrikes into bold text." | 1303 | "Translate overstrikes into bold text." |
| 845 | (interactive) | 1304 | (interactive) |
| 846 | (save-excursion | 1305 | (save-excursion |
| 847 | (goto-char (point-min)) | 1306 | (when (article-goto-body) |
| 848 | (when (search-forward "\n\n" nil t) | ||
| 849 | (let ((buffer-read-only nil)) | 1307 | (let ((buffer-read-only nil)) |
| 850 | (while (search-forward "\b" nil t) | 1308 | (while (search-forward "\b" nil t) |
| 851 | (let ((next (following-char)) | 1309 | (let ((next (char-after)) |
| 852 | (previous (char-after (- (point) 2)))) | 1310 | (previous (char-after (- (point) 2)))) |
| 853 | ;; We do the boldification/underlining by hiding the | 1311 | ;; We do the boldification/underlining by hiding the |
| 854 | ;; overstrikes and putting the proper text property | 1312 | ;; overstrikes and putting the proper text property |
| @@ -867,32 +1325,46 @@ characters to translate to." | |||
| 867 | (put-text-property | 1325 | (put-text-property |
| 868 | (point) (1+ (point)) 'face 'underline))))))))) | 1326 | (point) (1+ (point)) 'face 'underline))))))))) |
| 869 | 1327 | ||
| 870 | (defun article-fill () | 1328 | (defun article-fill-long-lines () |
| 871 | "Format too long lines." | 1329 | "Fill lines that are wider than the window width." |
| 872 | (interactive) | 1330 | (interactive) |
| 873 | (save-excursion | 1331 | (save-excursion |
| 874 | (let ((buffer-read-only nil)) | 1332 | (let ((buffer-read-only nil) |
| 875 | (widen) | 1333 | (width (window-width (get-buffer-window (current-buffer))))) |
| 876 | (goto-char (point-min)) | 1334 | (save-restriction |
| 877 | (search-forward "\n\n" nil t) | 1335 | (article-goto-body) |
| 878 | (end-of-line 1) | 1336 | (let ((adaptive-fill-mode nil)) |
| 879 | (let ((paragraph-start "^[>|#:<;* ]*[ \t]*$") | 1337 | (while (not (eobp)) |
| 880 | (adaptive-fill-regexp "[ \t]*\\([|#:<;>*]+ *\\)?") | 1338 | (end-of-line) |
| 881 | (adaptive-fill-mode t)) | 1339 | (when (>= (current-column) (min fill-column width)) |
| 882 | (while (not (eobp)) | 1340 | (narrow-to-region (point) (gnus-point-at-bol)) |
| 883 | (and (>= (current-column) (min fill-column (window-width))) | 1341 | (fill-paragraph nil) |
| 884 | (/= (preceding-char) ?:) | 1342 | (goto-char (point-max)) |
| 885 | (fill-paragraph nil)) | 1343 | (widen)) |
| 886 | (end-of-line 2)))))) | 1344 | (forward-line 1))))))) |
| 1345 | |||
| 1346 | (defun article-capitalize-sentences () | ||
| 1347 | "Capitalize the first word in each sentence." | ||
| 1348 | (interactive) | ||
| 1349 | (save-excursion | ||
| 1350 | (let ((buffer-read-only nil) | ||
| 1351 | (paragraph-start "^[\n\^L]")) | ||
| 1352 | (article-goto-body) | ||
| 1353 | (while (not (eobp)) | ||
| 1354 | (capitalize-word 1) | ||
| 1355 | (forward-sentence))))) | ||
| 887 | 1356 | ||
| 888 | (defun article-remove-cr () | 1357 | (defun article-remove-cr () |
| 889 | "Remove carriage returns from an article." | 1358 | "Remove trailing CRs and then translate remaining CRs into LFs." |
| 890 | (interactive) | 1359 | (interactive) |
| 891 | (save-excursion | 1360 | (save-excursion |
| 892 | (let ((buffer-read-only nil)) | 1361 | (let ((buffer-read-only nil)) |
| 893 | (goto-char (point-min)) | 1362 | (goto-char (point-min)) |
| 1363 | (while (re-search-forward "\r+$" nil t) | ||
| 1364 | (replace-match "" t t)) | ||
| 1365 | (goto-char (point-min)) | ||
| 894 | (while (search-forward "\r" nil t) | 1366 | (while (search-forward "\r" nil t) |
| 895 | (replace-match "" t t))))) | 1367 | (replace-match "\n" t t))))) |
| 896 | 1368 | ||
| 897 | (defun article-remove-trailing-blank-lines () | 1369 | (defun article-remove-trailing-blank-lines () |
| 898 | "Remove all trailing blank lines from the article." | 1370 | "Remove all trailing blank lines from the article." |
| @@ -904,7 +1376,9 @@ characters to translate to." | |||
| 904 | (point) | 1376 | (point) |
| 905 | (progn | 1377 | (progn |
| 906 | (while (and (not (bobp)) | 1378 | (while (and (not (bobp)) |
| 907 | (looking-at "^[ \t]*$")) | 1379 | (looking-at "^[ \t]*$") |
| 1380 | (not (gnus-annotation-in-region-p | ||
| 1381 | (point) (gnus-point-at-eol)))) | ||
| 908 | (forward-line -1)) | 1382 | (forward-line -1)) |
| 909 | (forward-line 1) | 1383 | (forward-line 1) |
| 910 | (point)))))) | 1384 | (point)))))) |
| @@ -920,7 +1394,8 @@ characters to translate to." | |||
| 920 | (case-fold-search t) | 1394 | (case-fold-search t) |
| 921 | from last) | 1395 | from last) |
| 922 | (save-restriction | 1396 | (save-restriction |
| 923 | (nnheader-narrow-to-headers) | 1397 | (article-narrow-to-head) |
| 1398 | (goto-char (point-min)) | ||
| 924 | (setq from (message-fetch-field "from")) | 1399 | (setq from (message-fetch-field "from")) |
| 925 | (goto-char (point-min)) | 1400 | (goto-char (point-min)) |
| 926 | (while (and gnus-article-x-face-command | 1401 | (while (and gnus-article-x-face-command |
| @@ -959,99 +1434,212 @@ characters to translate to." | |||
| 959 | (process-send-region "article-x-face" beg end) | 1434 | (process-send-region "article-x-face" beg end) |
| 960 | (process-send-eof "article-x-face")))))))))) | 1435 | (process-send-eof "article-x-face")))))))))) |
| 961 | 1436 | ||
| 962 | (defun gnus-hack-decode-rfc1522 () | 1437 | (defun article-decode-mime-words () |
| 963 | "Emergency hack function for avoiding problems when decoding." | 1438 | "Decode all MIME-encoded words in the article." |
| 964 | (let ((buffer-read-only nil)) | 1439 | (interactive) |
| 965 | (goto-char (point-min)) | 1440 | (save-excursion |
| 966 | ;; Remove encoded TABs. | 1441 | (set-buffer gnus-article-buffer) |
| 967 | (while (search-forward "=09" nil t) | 1442 | (let ((inhibit-point-motion-hooks t) |
| 968 | (replace-match " " t t)) | 1443 | buffer-read-only |
| 969 | ;; Remove encoded newlines. | 1444 | (mail-parse-charset gnus-newsgroup-charset) |
| 970 | (goto-char (point-min)) | 1445 | (mail-parse-ignored-charsets |
| 971 | (while (search-forward "=10" nil t) | 1446 | (save-excursion (set-buffer gnus-summary-buffer) |
| 972 | (replace-match " " t t)))) | 1447 | gnus-newsgroup-ignored-charsets))) |
| 973 | 1448 | (mail-decode-encoded-word-region (point-min) (point-max))))) | |
| 974 | (defalias 'gnus-decode-rfc1522 'article-decode-rfc1522) | 1449 | |
| 975 | (defalias 'gnus-article-decode-rfc1522 'article-decode-rfc1522) | 1450 | (defun article-decode-charset (&optional prompt) |
| 976 | (defun article-decode-rfc1522 () | 1451 | "Decode charset-encoded text in the article. |
| 977 | "Hack to remove QP encoding from headers." | 1452 | If PROMPT (the prefix), prompt for a coding system to use." |
| 978 | (let ((case-fold-search t) | 1453 | (interactive "P") |
| 979 | (inhibit-point-motion-hooks t) | 1454 | (let ((inhibit-point-motion-hooks t) (case-fold-search t) |
| 980 | (buffer-read-only nil) | 1455 | buffer-read-only |
| 981 | string) | 1456 | (mail-parse-charset gnus-newsgroup-charset) |
| 1457 | (mail-parse-ignored-charsets | ||
| 1458 | (save-excursion (condition-case nil | ||
| 1459 | (set-buffer gnus-summary-buffer) | ||
| 1460 | (error)) | ||
| 1461 | gnus-newsgroup-ignored-charsets)) | ||
| 1462 | ct cte ctl charset format) | ||
| 1463 | (save-excursion | ||
| 982 | (save-restriction | 1464 | (save-restriction |
| 983 | (narrow-to-region | 1465 | (article-narrow-to-head) |
| 984 | (goto-char (point-min)) | 1466 | (setq ct (message-fetch-field "Content-Type" t) |
| 985 | (or (search-forward "\n\n" nil t) (point-max))) | 1467 | cte (message-fetch-field "Content-Transfer-Encoding" t) |
| 986 | (goto-char (point-min)) | 1468 | ctl (and ct (ignore-errors |
| 987 | (while (re-search-forward | 1469 | (mail-header-parse-content-type ct))) |
| 988 | "=\\?iso-8859-1\\?q\\?\\([^?\t\n]*\\)\\?=" nil t) | 1470 | charset (cond |
| 989 | (setq string (match-string 1)) | 1471 | (prompt |
| 990 | (save-restriction | 1472 | (mm-read-coding-system "Charset to decode: ")) |
| 991 | (narrow-to-region (match-beginning 0) (match-end 0)) | 1473 | (ctl |
| 992 | (delete-region (point-min) (point-max)) | 1474 | (mail-content-type-get ctl 'charset))) |
| 993 | (insert string) | 1475 | format (and ctl (mail-content-type-get ctl 'format))) |
| 994 | (article-mime-decode-quoted-printable | 1476 | (when cte |
| 995 | (goto-char (point-min)) (point-max)) | 1477 | (setq cte (mail-header-strip cte))) |
| 996 | (subst-char-in-region (point-min) (point-max) ?_ ? ) | 1478 | (if (and ctl (not (string-match "/" (car ctl)))) |
| 997 | (goto-char (point-max))) | 1479 | (setq ctl nil)) |
| 998 | (goto-char (point-min)))))) | 1480 | (goto-char (point-max))) |
| 1481 | (forward-line 1) | ||
| 1482 | (save-restriction | ||
| 1483 | (narrow-to-region (point) (point-max)) | ||
| 1484 | (when (and (eq mail-parse-charset 'gnus-decoded) | ||
| 1485 | (eq (mm-body-7-or-8) '8bit)) | ||
| 1486 | ;; The text code could have been decoded. | ||
| 1487 | (setq charset mail-parse-charset)) | ||
| 1488 | (when (and (or (not ctl) | ||
| 1489 | (equal (car ctl) "text/plain")) | ||
| 1490 | (not format)) ;; article with format will decode later. | ||
| 1491 | (mm-decode-body | ||
| 1492 | charset (and cte (intern (downcase | ||
| 1493 | (gnus-strip-whitespace cte)))) | ||
| 1494 | (car ctl))))))) | ||
| 1495 | |||
| 1496 | (defun article-decode-encoded-words () | ||
| 1497 | "Remove encoded-word encoding from headers." | ||
| 1498 | (let ((inhibit-point-motion-hooks t) | ||
| 1499 | (mail-parse-charset gnus-newsgroup-charset) | ||
| 1500 | (mail-parse-ignored-charsets | ||
| 1501 | (save-excursion (condition-case nil | ||
| 1502 | (set-buffer gnus-summary-buffer) | ||
| 1503 | (error)) | ||
| 1504 | gnus-newsgroup-ignored-charsets)) | ||
| 1505 | buffer-read-only) | ||
| 1506 | (save-restriction | ||
| 1507 | (article-narrow-to-head) | ||
| 1508 | (funcall gnus-decode-header-function (point-min) (point-max))))) | ||
| 999 | 1509 | ||
| 1000 | (defun article-de-quoted-unreadable (&optional force) | 1510 | (defun article-de-quoted-unreadable (&optional force) |
| 1001 | "Do a naive translation of a quoted-printable-encoded article. | 1511 | "Translate a quoted-printable-encoded article. |
| 1002 | This is in no way, shape or form meant as a replacement for real MIME | ||
| 1003 | processing, but is simply a stop-gap measure until MIME support is | ||
| 1004 | written. | ||
| 1005 | If FORCE, decode the article whether it is marked as quoted-printable | 1512 | If FORCE, decode the article whether it is marked as quoted-printable |
| 1006 | or not." | 1513 | or not." |
| 1007 | (interactive (list 'force)) | 1514 | (interactive (list 'force)) |
| 1008 | (save-excursion | 1515 | (save-excursion |
| 1009 | (let ((case-fold-search t) | 1516 | (let ((buffer-read-only nil) type charset) |
| 1010 | (buffer-read-only nil) | 1517 | (if (gnus-buffer-live-p gnus-original-article-buffer) |
| 1011 | (type (gnus-fetch-field "content-transfer-encoding"))) | 1518 | (with-current-buffer gnus-original-article-buffer |
| 1012 | (gnus-article-decode-rfc1522) | 1519 | (setq type |
| 1520 | (gnus-fetch-field "content-transfer-encoding")) | ||
| 1521 | (let* ((ct (gnus-fetch-field "content-type")) | ||
| 1522 | (ctl (and ct | ||
| 1523 | (ignore-errors | ||
| 1524 | (mail-header-parse-content-type ct))))) | ||
| 1525 | (setq charset (and ctl | ||
| 1526 | (mail-content-type-get ctl 'charset))) | ||
| 1527 | (if (stringp charset) | ||
| 1528 | (setq charset (intern (downcase charset))))))) | ||
| 1529 | (unless charset | ||
| 1530 | (setq charset gnus-newsgroup-charset)) | ||
| 1013 | (when (or force | 1531 | (when (or force |
| 1014 | (and type (string-match "quoted-printable" (downcase type)))) | 1532 | (and type (string-match "quoted-printable" (downcase type)))) |
| 1015 | (goto-char (point-min)) | 1533 | (article-goto-body) |
| 1016 | (search-forward "\n\n" nil 'move) | 1534 | (quoted-printable-decode-region (point) (point-max) charset))))) |
| 1017 | (article-mime-decode-quoted-printable (point) (point-max)))))) | 1535 | |
| 1018 | 1536 | (defun article-de-base64-unreadable (&optional force) | |
| 1019 | (defun article-mime-decode-quoted-printable-buffer () | 1537 | "Translate a base64 article. |
| 1020 | "Decode Quoted-Printable in the current buffer." | 1538 | If FORCE, decode the article whether it is marked as base64 not." |
| 1021 | (article-mime-decode-quoted-printable (point-min) (point-max))) | 1539 | (interactive (list 'force)) |
| 1022 | 1540 | (save-excursion | |
| 1023 | (defun article-mime-decode-quoted-printable (from to) | 1541 | (let ((buffer-read-only nil) type charset) |
| 1024 | "Decode Quoted-Printable in the region between FROM and TO." | 1542 | (if (gnus-buffer-live-p gnus-original-article-buffer) |
| 1025 | (interactive "r") | 1543 | (with-current-buffer gnus-original-article-buffer |
| 1026 | (goto-char from) | 1544 | (setq type |
| 1027 | (while (search-forward "=" to t) | 1545 | (gnus-fetch-field "content-transfer-encoding")) |
| 1028 | (cond ((eq (following-char) ?\n) | 1546 | (let* ((ct (gnus-fetch-field "content-type")) |
| 1029 | (delete-char -1) | 1547 | (ctl (and ct |
| 1030 | (delete-char 1)) | 1548 | (ignore-errors |
| 1031 | ((looking-at "[0-9A-F][0-9A-F]") | 1549 | (mail-header-parse-content-type ct))))) |
| 1032 | (subst-char-in-region | 1550 | (setq charset (and ctl |
| 1033 | (1- (point)) (point) ?= | 1551 | (mail-content-type-get ctl 'charset))) |
| 1034 | (hexl-hex-string-to-integer | 1552 | (if (stringp charset) |
| 1035 | (buffer-substring (point) (+ 2 (point))))) | 1553 | (setq charset (intern (downcase charset))))))) |
| 1036 | (delete-char 2)) | 1554 | (unless charset |
| 1037 | ((looking-at "=") | 1555 | (setq charset gnus-newsgroup-charset)) |
| 1038 | (delete-char 1)) | 1556 | (when (or force |
| 1039 | ((gnus-message 3 "Malformed MIME quoted-printable message"))))) | 1557 | (and type (string-match "base64" (downcase type)))) |
| 1040 | 1558 | (article-goto-body) | |
| 1041 | (defun article-hide-pgp (&optional arg) | 1559 | (save-restriction |
| 1042 | "Toggle hiding of any PGP headers and signatures in the current article. | 1560 | (narrow-to-region (point) (point-max)) |
| 1043 | If given a negative prefix, always show; if given a positive prefix, | 1561 | (base64-decode-region (point-min) (point-max)) |
| 1044 | always hide." | 1562 | (if (mm-coding-system-p charset) |
| 1045 | (interactive (gnus-article-hidden-arg)) | 1563 | (mm-decode-coding-region (point-min) (point-max) charset))))))) |
| 1046 | (unless (gnus-article-check-hidden-text 'pgp arg) | 1564 | |
| 1047 | (save-excursion | 1565 | (eval-when-compile |
| 1566 | (require 'rfc1843)) | ||
| 1567 | |||
| 1568 | (defun article-decode-HZ () | ||
| 1569 | "Translate a HZ-encoded article." | ||
| 1570 | (interactive) | ||
| 1571 | (require 'rfc1843) | ||
| 1572 | (save-excursion | ||
| 1573 | (let ((buffer-read-only nil)) | ||
| 1574 | (rfc1843-decode-region (point-min) (point-max))))) | ||
| 1575 | |||
| 1576 | (defun article-wash-html () | ||
| 1577 | "Format an html article." | ||
| 1578 | (interactive) | ||
| 1579 | (save-excursion | ||
| 1580 | (let ((buffer-read-only nil) | ||
| 1581 | charset) | ||
| 1582 | (if (gnus-buffer-live-p gnus-original-article-buffer) | ||
| 1583 | (with-current-buffer gnus-original-article-buffer | ||
| 1584 | (let* ((ct (gnus-fetch-field "content-type")) | ||
| 1585 | (ctl (and ct | ||
| 1586 | (ignore-errors | ||
| 1587 | (mail-header-parse-content-type ct))))) | ||
| 1588 | (setq charset (and ctl | ||
| 1589 | (mail-content-type-get ctl 'charset))) | ||
| 1590 | (if (stringp charset) | ||
| 1591 | (setq charset (intern (downcase charset))))))) | ||
| 1592 | (unless charset | ||
| 1593 | (setq charset gnus-newsgroup-charset)) | ||
| 1594 | (article-goto-body) | ||
| 1595 | (save-window-excursion | ||
| 1596 | (save-restriction | ||
| 1597 | (narrow-to-region (point) (point-max)) | ||
| 1598 | (mm-setup-w3) | ||
| 1599 | (let ((w3-strict-width (window-width)) | ||
| 1600 | (url-standalone-mode t)) | ||
| 1601 | (condition-case var | ||
| 1602 | (w3-region (point-min) (point-max)) | ||
| 1603 | (error)))))))) | ||
| 1604 | |||
| 1605 | (defun article-hide-list-identifiers () | ||
| 1606 | "Remove list identifies from the Subject header. | ||
| 1607 | The `gnus-list-identifiers' variable specifies what to do." | ||
| 1608 | (interactive) | ||
| 1609 | (save-excursion | ||
| 1610 | (save-restriction | ||
| 1611 | (let ((inhibit-point-motion-hooks t) | ||
| 1612 | buffer-read-only) | ||
| 1613 | (article-narrow-to-head) | ||
| 1614 | (let ((regexp (if (stringp gnus-list-identifiers) gnus-list-identifiers | ||
| 1615 | (mapconcat 'identity gnus-list-identifiers " *\\|")))) | ||
| 1616 | (when regexp | ||
| 1617 | (goto-char (point-min)) | ||
| 1618 | (when (re-search-forward | ||
| 1619 | (concat "^Subject: +\\(\\(\\(Re: +\\)?\\(" regexp | ||
| 1620 | " *\\)\\)+\\(Re: +\\)?\\)") | ||
| 1621 | nil t) | ||
| 1622 | (let ((s (or (match-string 3) (match-string 5)))) | ||
| 1623 | (delete-region (match-beginning 1) (match-end 1)) | ||
| 1624 | (when s | ||
| 1625 | (goto-char (match-beginning 1)) | ||
| 1626 | (insert s)))))))))) | ||
| 1627 | |||
| 1628 | (defun article-hide-pgp () | ||
| 1629 | "Remove any PGP headers and signatures in the current article." | ||
| 1630 | (interactive) | ||
| 1631 | (save-excursion | ||
| 1632 | (save-restriction | ||
| 1048 | (let ((inhibit-point-motion-hooks t) | 1633 | (let ((inhibit-point-motion-hooks t) |
| 1049 | buffer-read-only beg end) | 1634 | buffer-read-only beg end) |
| 1050 | (widen) | 1635 | (article-goto-body) |
| 1051 | (goto-char (point-min)) | ||
| 1052 | ;; Hide the "header". | 1636 | ;; Hide the "header". |
| 1053 | (when (search-forward "\n-----BEGIN PGP SIGNED MESSAGE-----\n" nil t) | 1637 | (when (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\n" nil t) |
| 1054 | (delete-region (1+ (match-beginning 0)) (match-end 0)) | 1638 | (push 'pgp gnus-article-wash-types) |
| 1639 | (delete-region (match-beginning 0) (match-end 0)) | ||
| 1640 | ;; Remove armor headers (rfc2440 6.2) | ||
| 1641 | (delete-region (point) (or (re-search-forward "^[ \t]*\n" nil t) | ||
| 1642 | (point))) | ||
| 1055 | (setq beg (point)) | 1643 | (setq beg (point)) |
| 1056 | ;; Hide the actual signature. | 1644 | ;; Hide the actual signature. |
| 1057 | (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t) | 1645 | (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t) |
| @@ -1081,25 +1669,62 @@ always hide." | |||
| 1081 | (unless (gnus-article-check-hidden-text 'pem arg) | 1669 | (unless (gnus-article-check-hidden-text 'pem arg) |
| 1082 | (save-excursion | 1670 | (save-excursion |
| 1083 | (let (buffer-read-only end) | 1671 | (let (buffer-read-only end) |
| 1084 | (widen) | ||
| 1085 | (goto-char (point-min)) | 1672 | (goto-char (point-min)) |
| 1086 | ;; hide the horrendously ugly "header". | 1673 | ;; Hide the horrendously ugly "header". |
| 1087 | (and (search-forward "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n" | 1674 | (when (and (search-forward |
| 1088 | nil | 1675 | "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n" |
| 1089 | t) | 1676 | nil t) |
| 1090 | (setq end (1+ (match-beginning 0))) | 1677 | (setq end (1+ (match-beginning 0)))) |
| 1091 | (gnus-article-hide-text-type | 1678 | (push 'pem gnus-article-wash-types) |
| 1092 | end | 1679 | (gnus-article-hide-text-type |
| 1093 | (if (search-forward "\n\n" nil t) | 1680 | end |
| 1094 | (match-end 0) | 1681 | (if (search-forward "\n\n" nil t) |
| 1095 | (point-max)) | 1682 | (match-end 0) |
| 1096 | 'pem)) | 1683 | (point-max)) |
| 1097 | ;; hide the trailer as well | 1684 | 'pem) |
| 1098 | (and (search-forward "\n-----END PRIVACY-ENHANCED MESSAGE-----\n" | 1685 | ;; Hide the trailer as well |
| 1099 | nil | 1686 | (when (search-forward "\n-----END PRIVACY-ENHANCED MESSAGE-----\n" |
| 1100 | t) | 1687 | nil t) |
| 1101 | (gnus-article-hide-text-type | 1688 | (gnus-article-hide-text-type |
| 1102 | (match-beginning 0) (match-end 0) 'pem)))))) | 1689 | (match-beginning 0) (match-end 0) 'pem))))))) |
| 1690 | |||
| 1691 | (defun article-strip-banner () | ||
| 1692 | "Strip the banner specified by the `banner' group parameter." | ||
| 1693 | (interactive) | ||
| 1694 | (save-excursion | ||
| 1695 | (save-restriction | ||
| 1696 | (let ((inhibit-point-motion-hooks t) | ||
| 1697 | (banner (gnus-group-get-parameter gnus-newsgroup-name 'banner)) | ||
| 1698 | (gnus-signature-limit nil) | ||
| 1699 | buffer-read-only beg end) | ||
| 1700 | (when banner | ||
| 1701 | (article-goto-body) | ||
| 1702 | (cond | ||
| 1703 | ((eq banner 'signature) | ||
| 1704 | (when (gnus-article-narrow-to-signature) | ||
| 1705 | (widen) | ||
| 1706 | (forward-line -1) | ||
| 1707 | (delete-region (point) (point-max)))) | ||
| 1708 | ((stringp banner) | ||
| 1709 | (while (re-search-forward banner nil t) | ||
| 1710 | (delete-region (match-beginning 0) (match-end 0)))))))))) | ||
| 1711 | |||
| 1712 | (defun article-babel () | ||
| 1713 | "Translate article using an online translation service." | ||
| 1714 | (interactive) | ||
| 1715 | (require 'babel) | ||
| 1716 | (save-excursion | ||
| 1717 | (set-buffer gnus-article-buffer) | ||
| 1718 | (when (article-goto-body) | ||
| 1719 | (let* ((buffer-read-only nil) | ||
| 1720 | (start (point)) | ||
| 1721 | (end (point-max)) | ||
| 1722 | (orig (buffer-substring start end)) | ||
| 1723 | (trans (babel-as-string orig))) | ||
| 1724 | (save-restriction | ||
| 1725 | (narrow-to-region start end) | ||
| 1726 | (delete-region start end) | ||
| 1727 | (insert trans)))))) | ||
| 1103 | 1728 | ||
| 1104 | (defun article-hide-signature (&optional arg) | 1729 | (defun article-hide-signature (&optional arg) |
| 1105 | "Hide the signature in the current article. | 1730 | "Hide the signature in the current article. |
| @@ -1114,18 +1739,50 @@ always hide." | |||
| 1114 | (gnus-article-hide-text-type | 1739 | (gnus-article-hide-text-type |
| 1115 | (point-min) (point-max) 'signature))))))) | 1740 | (point-min) (point-max) 'signature))))))) |
| 1116 | 1741 | ||
| 1742 | (defun article-strip-headers-in-body () | ||
| 1743 | "Strip offensive headers from bodies." | ||
| 1744 | (interactive) | ||
| 1745 | (save-excursion | ||
| 1746 | (article-goto-body) | ||
| 1747 | (let ((case-fold-search t)) | ||
| 1748 | (when (looking-at "x-no-archive:") | ||
| 1749 | (gnus-delete-line))))) | ||
| 1750 | |||
| 1117 | (defun article-strip-leading-blank-lines () | 1751 | (defun article-strip-leading-blank-lines () |
| 1118 | "Remove all blank lines from the beginning of the article." | 1752 | "Remove all blank lines from the beginning of the article." |
| 1119 | (interactive) | 1753 | (interactive) |
| 1120 | (save-excursion | 1754 | (save-excursion |
| 1121 | (let ((inhibit-point-motion-hooks t) | 1755 | (let ((inhibit-point-motion-hooks t) |
| 1122 | buffer-read-only) | 1756 | buffer-read-only) |
| 1123 | (goto-char (point-min)) | 1757 | (when (article-goto-body) |
| 1124 | (when (search-forward "\n\n" nil t) | ||
| 1125 | (while (and (not (eobp)) | 1758 | (while (and (not (eobp)) |
| 1126 | (looking-at "[ \t]*$")) | 1759 | (looking-at "[ \t]*$")) |
| 1127 | (gnus-delete-line)))))) | 1760 | (gnus-delete-line)))))) |
| 1128 | 1761 | ||
| 1762 | (defun article-narrow-to-head () | ||
| 1763 | "Narrow the buffer to the head of the message. | ||
| 1764 | Point is left at the beginning of the narrowed-to region." | ||
| 1765 | (narrow-to-region | ||
| 1766 | (goto-char (point-min)) | ||
| 1767 | (if (search-forward "\n\n" nil 1) | ||
| 1768 | (1- (point)) | ||
| 1769 | (point-max))) | ||
| 1770 | (goto-char (point-min))) | ||
| 1771 | |||
| 1772 | (defun article-goto-body () | ||
| 1773 | "Place point at the start of the body." | ||
| 1774 | (goto-char (point-min)) | ||
| 1775 | (cond | ||
| 1776 | ;; This variable is only bound when dealing with separate | ||
| 1777 | ;; MIME body parts. | ||
| 1778 | (article-goto-body-goes-to-point-min-p | ||
| 1779 | t) | ||
| 1780 | ((search-forward "\n\n" nil t) | ||
| 1781 | t) | ||
| 1782 | (t | ||
| 1783 | (goto-char (point-max)) | ||
| 1784 | nil))) | ||
| 1785 | |||
| 1129 | (defun article-strip-multiple-blank-lines () | 1786 | (defun article-strip-multiple-blank-lines () |
| 1130 | "Replace consecutive blank lines with one empty line." | 1787 | "Replace consecutive blank lines with one empty line." |
| 1131 | (interactive) | 1788 | (interactive) |
| @@ -1133,15 +1790,17 @@ always hide." | |||
| 1133 | (let ((inhibit-point-motion-hooks t) | 1790 | (let ((inhibit-point-motion-hooks t) |
| 1134 | buffer-read-only) | 1791 | buffer-read-only) |
| 1135 | ;; First make all blank lines empty. | 1792 | ;; First make all blank lines empty. |
| 1136 | (goto-char (point-min)) | 1793 | (article-goto-body) |
| 1137 | (search-forward "\n\n" nil t) | ||
| 1138 | (while (re-search-forward "^[ \t]+$" nil t) | 1794 | (while (re-search-forward "^[ \t]+$" nil t) |
| 1139 | (replace-match "" nil t)) | 1795 | (unless (gnus-annotation-in-region-p |
| 1796 | (match-beginning 0) (match-end 0)) | ||
| 1797 | (replace-match "" nil t))) | ||
| 1140 | ;; Then replace multiple empty lines with a single empty line. | 1798 | ;; Then replace multiple empty lines with a single empty line. |
| 1141 | (goto-char (point-min)) | 1799 | (article-goto-body) |
| 1142 | (search-forward "\n\n" nil t) | ||
| 1143 | (while (re-search-forward "\n\n\n+" nil t) | 1800 | (while (re-search-forward "\n\n\n+" nil t) |
| 1144 | (replace-match "\n\n" t t))))) | 1801 | (unless (gnus-annotation-in-region-p |
| 1802 | (match-beginning 0) (match-end 0)) | ||
| 1803 | (replace-match "\n\n" t t)))))) | ||
| 1145 | 1804 | ||
| 1146 | (defun article-strip-leading-space () | 1805 | (defun article-strip-leading-space () |
| 1147 | "Remove all white space from the beginning of the lines in the article." | 1806 | "Remove all white space from the beginning of the lines in the article." |
| @@ -1149,11 +1808,20 @@ always hide." | |||
| 1149 | (save-excursion | 1808 | (save-excursion |
| 1150 | (let ((inhibit-point-motion-hooks t) | 1809 | (let ((inhibit-point-motion-hooks t) |
| 1151 | buffer-read-only) | 1810 | buffer-read-only) |
| 1152 | (goto-char (point-min)) | 1811 | (article-goto-body) |
| 1153 | (search-forward "\n\n" nil t) | ||
| 1154 | (while (re-search-forward "^[ \t]+" nil t) | 1812 | (while (re-search-forward "^[ \t]+" nil t) |
| 1155 | (replace-match "" t t))))) | 1813 | (replace-match "" t t))))) |
| 1156 | 1814 | ||
| 1815 | (defun article-strip-trailing-space () | ||
| 1816 | "Remove all white space from the end of the lines in the article." | ||
| 1817 | (interactive) | ||
| 1818 | (save-excursion | ||
| 1819 | (let ((inhibit-point-motion-hooks t) | ||
| 1820 | buffer-read-only) | ||
| 1821 | (article-goto-body) | ||
| 1822 | (while (re-search-forward "[ \t]+$" nil t) | ||
| 1823 | (replace-match "" t t))))) | ||
| 1824 | |||
| 1157 | (defun article-strip-blank-lines () | 1825 | (defun article-strip-blank-lines () |
| 1158 | "Strip leading, trailing and multiple blank lines." | 1826 | "Strip leading, trailing and multiple blank lines." |
| 1159 | (interactive) | 1827 | (interactive) |
| @@ -1167,26 +1835,13 @@ always hide." | |||
| 1167 | (save-excursion | 1835 | (save-excursion |
| 1168 | (let ((inhibit-point-motion-hooks t) | 1836 | (let ((inhibit-point-motion-hooks t) |
| 1169 | buffer-read-only) | 1837 | buffer-read-only) |
| 1170 | (goto-char (point-min)) | 1838 | (article-goto-body) |
| 1171 | (search-forward "\n\n" nil t) | ||
| 1172 | (while (re-search-forward "^[ \t]*\n" nil t) | 1839 | (while (re-search-forward "^[ \t]*\n" nil t) |
| 1173 | (replace-match "" t t))))) | 1840 | (replace-match "" t t))))) |
| 1174 | 1841 | ||
| 1175 | (defvar mime::preview/content-list) | ||
| 1176 | (defvar mime::preview-content-info/point-min) | ||
| 1177 | (defun gnus-article-narrow-to-signature () | 1842 | (defun gnus-article-narrow-to-signature () |
| 1178 | "Narrow to the signature; return t if a signature is found, else nil." | 1843 | "Narrow to the signature; return t if a signature is found, else nil." |
| 1179 | (widen) | ||
| 1180 | (let ((inhibit-point-motion-hooks t)) | 1844 | (let ((inhibit-point-motion-hooks t)) |
| 1181 | (when (and (boundp 'mime::preview/content-list) | ||
| 1182 | mime::preview/content-list) | ||
| 1183 | ;; We have a MIMEish article, so we use the MIME data to narrow. | ||
| 1184 | (let ((pcinfo (car (last mime::preview/content-list)))) | ||
| 1185 | (ignore-errors | ||
| 1186 | (narrow-to-region | ||
| 1187 | (funcall (intern "mime::preview-content-info/point-min") pcinfo) | ||
| 1188 | (point-max))))) | ||
| 1189 | |||
| 1190 | (when (gnus-article-search-signature) | 1845 | (when (gnus-article-search-signature) |
| 1191 | (forward-line 1) | 1846 | (forward-line 1) |
| 1192 | ;; Check whether we have some limits to what we consider | 1847 | ;; Check whether we have some limits to what we consider |
| @@ -1226,38 +1881,6 @@ Put point at the beginning of the signature separator." | |||
| 1226 | (goto-char cur) | 1881 | (goto-char cur) |
| 1227 | nil))) | 1882 | nil))) |
| 1228 | 1883 | ||
| 1229 | (eval-and-compile | ||
| 1230 | (autoload 'w3-display "w3-parse") | ||
| 1231 | (autoload 'w3-do-setup "w3" "" t) | ||
| 1232 | (autoload 'w3-region "w3-display" "" t)) | ||
| 1233 | |||
| 1234 | (defun gnus-article-treat-html () | ||
| 1235 | "Render HTML." | ||
| 1236 | (interactive) | ||
| 1237 | (let ((cbuf (current-buffer))) | ||
| 1238 | (set-buffer gnus-article-buffer) | ||
| 1239 | (let (buf buffer-read-only b e) | ||
| 1240 | (w3-do-setup) | ||
| 1241 | (goto-char (point-min)) | ||
| 1242 | (narrow-to-region | ||
| 1243 | (if (search-forward "\n\n" nil t) | ||
| 1244 | (setq b (point)) | ||
| 1245 | (point-max)) | ||
| 1246 | (setq e (point-max))) | ||
| 1247 | (nnheader-temp-write nil | ||
| 1248 | (insert-buffer-substring gnus-article-buffer b e) | ||
| 1249 | (require 'url) | ||
| 1250 | (save-window-excursion | ||
| 1251 | (w3-region (point-min) (point-max)) | ||
| 1252 | (setq buf (buffer-substring-no-properties (point-min) (point-max))))) | ||
| 1253 | (when buf | ||
| 1254 | (delete-region (point-min) (point-max)) | ||
| 1255 | (insert buf)) | ||
| 1256 | (widen) | ||
| 1257 | (goto-char (point-min)) | ||
| 1258 | (set-window-start (get-buffer-window (current-buffer)) (point-min)) | ||
| 1259 | (set-buffer cbuf)))) | ||
| 1260 | |||
| 1261 | (defun gnus-article-hidden-arg () | 1884 | (defun gnus-article-hidden-arg () |
| 1262 | "Return the current prefix arg as a number, or 0 if no prefix." | 1885 | "Return the current prefix arg as a number, or 0 if no prefix." |
| 1263 | (list (if current-prefix-arg | 1886 | (list (if current-prefix-arg |
| @@ -1270,7 +1893,6 @@ Arg can be nil or a number. Nil and positive means hide, negative | |||
| 1270 | means show, 0 means toggle." | 1893 | means show, 0 means toggle." |
| 1271 | (save-excursion | 1894 | (save-excursion |
| 1272 | (save-restriction | 1895 | (save-restriction |
| 1273 | (widen) | ||
| 1274 | (let ((hide (gnus-article-hidden-text-p type))) | 1896 | (let ((hide (gnus-article-hidden-text-p type))) |
| 1275 | (cond | 1897 | (cond |
| 1276 | ((or (null arg) | 1898 | ((or (null arg) |
| @@ -1287,12 +1909,13 @@ means show, 0 means toggle." | |||
| 1287 | "Say whether the current buffer contains hidden text of type TYPE." | 1909 | "Say whether the current buffer contains hidden text of type TYPE." |
| 1288 | (let ((pos (text-property-any (point-min) (point-max) 'article-type type))) | 1910 | (let ((pos (text-property-any (point-min) (point-max) 'article-type type))) |
| 1289 | (while (and pos | 1911 | (while (and pos |
| 1290 | (not (get-text-property pos 'invisible))) | 1912 | (not (get-text-property pos 'invisible)) |
| 1913 | (not (get-text-property pos 'dummy-invisible))) | ||
| 1291 | (setq pos | 1914 | (setq pos |
| 1292 | (text-property-any (1+ pos) (point-max) 'article-type type))) | 1915 | (text-property-any (1+ pos) (point-max) 'article-type type))) |
| 1293 | (if pos | 1916 | (if pos |
| 1294 | 'hidden | 1917 | 'hidden |
| 1295 | 'shown))) | 1918 | nil))) |
| 1296 | 1919 | ||
| 1297 | (defun gnus-article-show-hidden-text (type &optional hide) | 1920 | (defun gnus-article-show-hidden-text (type &optional hide) |
| 1298 | "Show all hidden text of type TYPE. | 1921 | "Show all hidden text of type TYPE. |
| @@ -1325,144 +1948,158 @@ If HIDE, hide the text instead." | |||
| 1325 | (defun article-date-ut (&optional type highlight header) | 1948 | (defun article-date-ut (&optional type highlight header) |
| 1326 | "Convert DATE date to universal time in the current article. | 1949 | "Convert DATE date to universal time in the current article. |
| 1327 | If TYPE is `local', convert to local time; if it is `lapsed', output | 1950 | If TYPE is `local', convert to local time; if it is `lapsed', output |
| 1328 | how much time has lapsed since DATE." | 1951 | how much time has lapsed since DATE. For `lapsed', the value of |
| 1952 | `gnus-article-date-lapsed-new-header' says whether the \"X-Sent:\" header | ||
| 1953 | should replace the \"Date:\" one, or should be added below it." | ||
| 1329 | (interactive (list 'ut t)) | 1954 | (interactive (list 'ut t)) |
| 1330 | (let* ((header (or header | 1955 | (let* ((header (or header |
| 1331 | (mail-header-date gnus-current-headers) | ||
| 1332 | (message-fetch-field "date") | 1956 | (message-fetch-field "date") |
| 1333 | "")) | 1957 | "")) |
| 1958 | (tdate-regexp "^Date:[ \t]\\|^X-Sent:[ \t]") | ||
| 1959 | (date-regexp | ||
| 1960 | (cond | ||
| 1961 | ((not gnus-article-date-lapsed-new-header) | ||
| 1962 | tdate-regexp) | ||
| 1963 | ((eq type 'lapsed) | ||
| 1964 | "^X-Sent:[ \t]") | ||
| 1965 | (t | ||
| 1966 | "^Date:[ \t]"))) | ||
| 1334 | (date (if (vectorp header) (mail-header-date header) | 1967 | (date (if (vectorp header) (mail-header-date header) |
| 1335 | header)) | 1968 | header)) |
| 1336 | (date-regexp "^Date:[ \t]\\|^X-Sent:[ \t]") | ||
| 1337 | (inhibit-point-motion-hooks t) | 1969 | (inhibit-point-motion-hooks t) |
| 1338 | bface eface newline) | 1970 | pos |
| 1339 | (when (and date (not (string= date ""))) | 1971 | bface eface) |
| 1340 | (save-excursion | 1972 | (save-excursion |
| 1341 | (save-restriction | 1973 | (save-restriction |
| 1342 | (nnheader-narrow-to-headers) | 1974 | (article-narrow-to-head) |
| 1975 | (when (re-search-forward tdate-regexp nil t) | ||
| 1976 | (setq bface (get-text-property (gnus-point-at-bol) 'face) | ||
| 1977 | date (or (get-text-property (gnus-point-at-bol) | ||
| 1978 | 'original-date) | ||
| 1979 | date) | ||
| 1980 | eface (get-text-property (1- (gnus-point-at-eol)) 'face)) | ||
| 1981 | (forward-line 1)) | ||
| 1982 | (when (and date (not (string= date ""))) | ||
| 1983 | (goto-char (point-min)) | ||
| 1343 | (let ((buffer-read-only nil)) | 1984 | (let ((buffer-read-only nil)) |
| 1344 | ;; Delete any old Date headers. | 1985 | ;; Delete any old Date headers. |
| 1345 | (if (re-search-forward date-regexp nil t) | 1986 | (while (re-search-forward date-regexp nil t) |
| 1346 | (progn | 1987 | (if pos |
| 1347 | (setq bface (get-text-property (gnus-point-at-bol) 'face) | ||
| 1348 | eface (get-text-property (1- (gnus-point-at-eol)) | ||
| 1349 | 'face)) | ||
| 1350 | (delete-region (progn (beginning-of-line) (point)) | 1988 | (delete-region (progn (beginning-of-line) (point)) |
| 1351 | (progn (end-of-line) (point))) | 1989 | (progn (forward-line 1) (point))) |
| 1352 | (beginning-of-line)) | 1990 | (delete-region (progn (beginning-of-line) (point)) |
| 1353 | (goto-char (point-max)) | 1991 | (progn (end-of-line) (point))) |
| 1354 | (setq newline t)) | 1992 | (setq pos (point)))) |
| 1355 | (insert (article-make-date-line date type)) | 1993 | (when (and (not pos) (re-search-forward tdate-regexp nil t)) |
| 1994 | (forward-line 1)) | ||
| 1995 | (if pos (goto-char pos)) | ||
| 1996 | (insert (article-make-date-line date (or type 'ut))) | ||
| 1997 | (when (not pos) | ||
| 1998 | (insert "\n") | ||
| 1999 | (forward-line -1)) | ||
| 1356 | ;; Do highlighting. | 2000 | ;; Do highlighting. |
| 1357 | (beginning-of-line) | 2001 | (beginning-of-line) |
| 1358 | (when (looking-at "\\([^:]+\\): *\\(.*\\)$") | 2002 | (when (looking-at "\\([^:]+\\): *\\(.*\\)$") |
| 1359 | (put-text-property (match-beginning 1) (1+ (match-end 1)) | 2003 | (put-text-property (match-beginning 1) (1+ (match-end 1)) |
| 2004 | 'original-date date) | ||
| 2005 | (put-text-property (match-beginning 1) (1+ (match-end 1)) | ||
| 1360 | 'face bface) | 2006 | 'face bface) |
| 1361 | (put-text-property (match-beginning 2) (match-end 2) | 2007 | (put-text-property (match-beginning 2) (match-end 2) |
| 1362 | 'face eface)) | 2008 | 'face eface)))))))) |
| 1363 | (when newline | ||
| 1364 | (end-of-line) | ||
| 1365 | (insert "\n")))))))) | ||
| 1366 | 2009 | ||
| 1367 | (defun article-make-date-line (date type) | 2010 | (defun article-make-date-line (date type) |
| 1368 | "Return a DATE line of TYPE." | 2011 | "Return a DATE line of TYPE." |
| 1369 | (cond | 2012 | (let ((time (condition-case () |
| 1370 | ;; Convert to the local timezone. We have to slap a | 2013 | (date-to-time date) |
| 1371 | ;; `condition-case' round the calls to the timezone | 2014 | (error '(0 0))))) |
| 1372 | ;; functions since they aren't particularly resistant to | 2015 | (cond |
| 1373 | ;; buggy dates. | 2016 | ;; Convert to the local timezone. We have to slap a |
| 1374 | ((eq type 'local) | 2017 | ;; `condition-case' round the calls to the timezone |
| 1375 | (concat "Date: " (condition-case () | 2018 | ;; functions since they aren't particularly resistant to |
| 1376 | (timezone-make-date-arpa-standard date) | 2019 | ;; buggy dates. |
| 1377 | (error date)))) | 2020 | ((eq type 'local) |
| 1378 | ;; Convert to Universal Time. | 2021 | (let ((tz (car (current-time-zone time)))) |
| 1379 | ((eq type 'ut) | 2022 | (format "Date: %s %s%02d%02d" (current-time-string time) |
| 1380 | (concat "Date: " | 2023 | (if (> tz 0) "+" "-") (/ (abs tz) 3600) |
| 1381 | (condition-case () | 2024 | (/ (% (abs tz) 3600) 60)))) |
| 1382 | (timezone-make-date-arpa-standard date nil "UT") | 2025 | ;; Convert to Universal Time. |
| 1383 | (error date)))) | 2026 | ((eq type 'ut) |
| 1384 | ;; Get the original date from the article. | 2027 | (concat "Date: " |
| 1385 | ((eq type 'original) | 2028 | (current-time-string |
| 1386 | (concat "Date: " date)) | 2029 | (let* ((e (parse-time-string date)) |
| 1387 | ;; Let the user define the format. | 2030 | (tm (apply 'encode-time e)) |
| 1388 | ((eq type 'user) | 2031 | (ms (car tm)) |
| 1389 | (if (gnus-functionp gnus-article-time-format) | 2032 | (ls (- (cadr tm) (car (current-time-zone time))))) |
| 1390 | (funcall | 2033 | (cond ((< ls 0) (list (1- ms) (+ ls 65536))) |
| 1391 | gnus-article-time-format | 2034 | ((> ls 65535) (list (1+ ms) (- ls 65536))) |
| 1392 | (ignore-errors | 2035 | (t (list ms ls))))) |
| 1393 | (gnus-encode-date | 2036 | " UT")) |
| 1394 | (timezone-make-date-arpa-standard | 2037 | ;; Get the original date from the article. |
| 1395 | date nil "UT")))) | 2038 | ((eq type 'original) |
| 1396 | (concat | 2039 | (concat "Date: " (if (string-match "\n+$" date) |
| 1397 | "Date: " | 2040 | (substring date 0 (match-beginning 0)) |
| 1398 | (format-time-string gnus-article-time-format | 2041 | date))) |
| 1399 | (ignore-errors | 2042 | ;; Let the user define the format. |
| 1400 | (gnus-encode-date | 2043 | ((eq type 'user) |
| 1401 | (timezone-make-date-arpa-standard | 2044 | (if (gnus-functionp gnus-article-time-format) |
| 1402 | date nil "UT"))))))) | 2045 | (funcall gnus-article-time-format time) |
| 1403 | ;; ISO 8601. | ||
| 1404 | ((eq type 'iso8601) | ||
| 1405 | (concat | ||
| 1406 | "Date: " | ||
| 1407 | (format-time-string "%Y%M%DT%h%m%s" | ||
| 1408 | (ignore-errors | ||
| 1409 | (gnus-encode-date | ||
| 1410 | (timezone-make-date-arpa-standard | ||
| 1411 | date nil "UT")))))) | ||
| 1412 | ;; Do an X-Sent lapsed format. | ||
| 1413 | ((eq type 'lapsed) | ||
| 1414 | ;; If the date is seriously mangled, the timezone functions are | ||
| 1415 | ;; liable to bug out, so we ignore all errors. | ||
| 1416 | (let* ((now (current-time)) | ||
| 1417 | (real-time | ||
| 1418 | (ignore-errors | ||
| 1419 | (gnus-time-minus | ||
| 1420 | (gnus-encode-date | ||
| 1421 | (timezone-make-date-arpa-standard | ||
| 1422 | (current-time-string now) | ||
| 1423 | (current-time-zone now) "UT")) | ||
| 1424 | (gnus-encode-date | ||
| 1425 | (timezone-make-date-arpa-standard | ||
| 1426 | date nil "UT"))))) | ||
| 1427 | (real-sec (and real-time | ||
| 1428 | (+ (* (float (car real-time)) 65536) | ||
| 1429 | (cadr real-time)))) | ||
| 1430 | (sec (and real-time (abs real-sec))) | ||
| 1431 | num prev) | ||
| 1432 | (cond | ||
| 1433 | ((null real-time) | ||
| 1434 | "X-Sent: Unknown") | ||
| 1435 | ((zerop sec) | ||
| 1436 | "X-Sent: Now") | ||
| 1437 | (t | ||
| 1438 | (concat | 2046 | (concat |
| 1439 | "X-Sent: " | 2047 | "Date: " |
| 1440 | ;; This is a bit convoluted, but basically we go | 2048 | (format-time-string gnus-article-time-format time)))) |
| 1441 | ;; through the time units for years, weeks, etc, | 2049 | ;; ISO 8601. |
| 1442 | ;; and divide things to see whether that results | 2050 | ((eq type 'iso8601) |
| 1443 | ;; in positive answers. | 2051 | (let ((tz (car (current-time-zone time)))) |
| 1444 | (mapconcat | 2052 | (concat |
| 1445 | (lambda (unit) | 2053 | "Date: " |
| 1446 | (if (zerop (setq num (ffloor (/ sec (cdr unit))))) | 2054 | (format-time-string "%Y%m%dT%H%M%S" time) |
| 1447 | ;; The (remaining) seconds are too few to | 2055 | (format "%s%02d%02d" |
| 1448 | ;; be divided into this time unit. | 2056 | (if (> tz 0) "+" "-") (/ (abs tz) 3600) |
| 1449 | "" | 2057 | (/ (% (abs tz) 3600) 60))))) |
| 1450 | ;; It's big enough, so we output it. | 2058 | ;; Do an X-Sent lapsed format. |
| 1451 | (setq sec (- sec (* num (cdr unit)))) | 2059 | ((eq type 'lapsed) |
| 1452 | (prog1 | 2060 | ;; If the date is seriously mangled, the timezone functions are |
| 1453 | (concat (if prev ", " "") (int-to-string | 2061 | ;; liable to bug out, so we ignore all errors. |
| 1454 | (floor num)) | 2062 | (let* ((now (current-time)) |
| 1455 | " " (symbol-name (car unit)) | 2063 | (real-time (subtract-time now time)) |
| 1456 | (if (> num 1) "s" "")) | 2064 | (real-sec (and real-time |
| 1457 | (setq prev t)))) | 2065 | (+ (* (float (car real-time)) 65536) |
| 1458 | article-time-units "") | 2066 | (cadr real-time)))) |
| 1459 | ;; If dates are odd, then it might appear like the | 2067 | (sec (and real-time (abs real-sec))) |
| 1460 | ;; article was sent in the future. | 2068 | num prev) |
| 1461 | (if (> real-sec 0) | 2069 | (cond |
| 1462 | " ago" | 2070 | ((null real-time) |
| 1463 | " in the future")))))) | 2071 | "X-Sent: Unknown") |
| 1464 | (t | 2072 | ((zerop sec) |
| 1465 | (error "Unknown conversion type: %s" type)))) | 2073 | "X-Sent: Now") |
| 2074 | (t | ||
| 2075 | (concat | ||
| 2076 | "X-Sent: " | ||
| 2077 | ;; This is a bit convoluted, but basically we go | ||
| 2078 | ;; through the time units for years, weeks, etc, | ||
| 2079 | ;; and divide things to see whether that results | ||
| 2080 | ;; in positive answers. | ||
| 2081 | (mapconcat | ||
| 2082 | (lambda (unit) | ||
| 2083 | (if (zerop (setq num (ffloor (/ sec (cdr unit))))) | ||
| 2084 | ;; The (remaining) seconds are too few to | ||
| 2085 | ;; be divided into this time unit. | ||
| 2086 | "" | ||
| 2087 | ;; It's big enough, so we output it. | ||
| 2088 | (setq sec (- sec (* num (cdr unit)))) | ||
| 2089 | (prog1 | ||
| 2090 | (concat (if prev ", " "") (int-to-string | ||
| 2091 | (floor num)) | ||
| 2092 | " " (symbol-name (car unit)) | ||
| 2093 | (if (> num 1) "s" "")) | ||
| 2094 | (setq prev t)))) | ||
| 2095 | article-time-units "") | ||
| 2096 | ;; If dates are odd, then it might appear like the | ||
| 2097 | ;; article was sent in the future. | ||
| 2098 | (if (> real-sec 0) | ||
| 2099 | " ago" | ||
| 2100 | " in the future")))))) | ||
| 2101 | (t | ||
| 2102 | (error "Unknown conversion type: %s" type))))) | ||
| 1466 | 2103 | ||
| 1467 | (defun article-date-local (&optional highlight) | 2104 | (defun article-date-local (&optional highlight) |
| 1468 | "Convert the current article date to the local timezone." | 2105 | "Convert the current article date to the local timezone." |
| @@ -1486,11 +2123,14 @@ function and want to see what the date was before converting." | |||
| 1486 | (let (deactivate-mark) | 2123 | (let (deactivate-mark) |
| 1487 | (save-excursion | 2124 | (save-excursion |
| 1488 | (ignore-errors | 2125 | (ignore-errors |
| 1489 | (when (gnus-buffer-live-p gnus-article-buffer) | 2126 | (walk-windows |
| 1490 | (set-buffer gnus-article-buffer) | 2127 | (lambda (w) |
| 1491 | (goto-char (point-min)) | 2128 | (set-buffer (window-buffer w)) |
| 1492 | (when (re-search-forward "^X-Sent:" nil t) | 2129 | (when (eq major-mode 'gnus-article-mode) |
| 1493 | (article-date-lapsed t))))))) | 2130 | (goto-char (point-min)) |
| 2131 | (when (re-search-forward "^X-Sent:" nil t) | ||
| 2132 | (article-date-lapsed t)))) | ||
| 2133 | nil 'visible))))) | ||
| 1494 | 2134 | ||
| 1495 | (defun gnus-start-date-timer (&optional n) | 2135 | (defun gnus-start-date-timer (&optional n) |
| 1496 | "Start a timer to update the X-Sent header in the article buffers. | 2136 | "Start a timer to update the X-Sent header in the article buffers. |
| @@ -1533,13 +2173,17 @@ This format is defined by the `gnus-article-time-format' variable." | |||
| 1533 | (interactive (gnus-article-hidden-arg)) | 2173 | (interactive (gnus-article-hidden-arg)) |
| 1534 | (unless (gnus-article-check-hidden-text 'emphasis arg) | 2174 | (unless (gnus-article-check-hidden-text 'emphasis arg) |
| 1535 | (save-excursion | 2175 | (save-excursion |
| 1536 | (let ((alist gnus-emphasis-alist) | 2176 | (let ((alist (or |
| 2177 | (condition-case nil | ||
| 2178 | (with-current-buffer gnus-summary-buffer | ||
| 2179 | gnus-article-emphasis-alist) | ||
| 2180 | (error)) | ||
| 2181 | gnus-emphasis-alist)) | ||
| 1537 | (buffer-read-only nil) | 2182 | (buffer-read-only nil) |
| 1538 | (props (append '(article-type emphasis) | 2183 | (props (append '(article-type emphasis) |
| 1539 | gnus-hidden-properties)) | 2184 | gnus-hidden-properties)) |
| 1540 | regexp elem beg invisible visible face) | 2185 | regexp elem beg invisible visible face) |
| 1541 | (goto-char (point-min)) | 2186 | (article-goto-body) |
| 1542 | (search-forward "\n\n" nil t) | ||
| 1543 | (setq beg (point)) | 2187 | (setq beg (point)) |
| 1544 | (while (setq elem (pop alist)) | 2188 | (while (setq elem (pop alist)) |
| 1545 | (goto-char beg) | 2189 | (goto-char beg) |
| @@ -1549,6 +2193,7 @@ This format is defined by the `gnus-article-time-format' variable." | |||
| 1549 | face (nth 3 elem)) | 2193 | face (nth 3 elem)) |
| 1550 | (while (re-search-forward regexp nil t) | 2194 | (while (re-search-forward regexp nil t) |
| 1551 | (when (and (match-beginning visible) (match-beginning invisible)) | 2195 | (when (and (match-beginning visible) (match-beginning invisible)) |
| 2196 | (push 'emphasis gnus-article-wash-types) | ||
| 1552 | (gnus-article-hide-text | 2197 | (gnus-article-hide-text |
| 1553 | (match-beginning invisible) (match-end invisible) props) | 2198 | (match-beginning invisible) (match-end invisible) props) |
| 1554 | (gnus-article-unhide-text-type | 2199 | (gnus-article-unhide-text-type |
| @@ -1557,6 +2202,26 @@ This format is defined by the `gnus-article-time-format' variable." | |||
| 1557 | (match-beginning visible) (match-end visible) 'face face) | 2202 | (match-beginning visible) (match-end visible) 'face face) |
| 1558 | (goto-char (match-end invisible))))))))) | 2203 | (goto-char (match-end invisible))))))))) |
| 1559 | 2204 | ||
| 2205 | (defun gnus-article-setup-highlight-words (&optional highlight-words) | ||
| 2206 | "Setup newsgroup emphasis alist." | ||
| 2207 | (unless gnus-article-emphasis-alist | ||
| 2208 | (let ((name (and gnus-newsgroup-name | ||
| 2209 | (gnus-group-real-name gnus-newsgroup-name)))) | ||
| 2210 | (make-local-variable 'gnus-article-emphasis-alist) | ||
| 2211 | (setq gnus-article-emphasis-alist | ||
| 2212 | (nconc | ||
| 2213 | (let ((alist gnus-group-highlight-words-alist) elem highlight) | ||
| 2214 | (while (setq elem (pop alist)) | ||
| 2215 | (when (and name (string-match (car elem) name)) | ||
| 2216 | (setq alist nil | ||
| 2217 | highlight (copy-sequence (cdr elem))))) | ||
| 2218 | highlight) | ||
| 2219 | (copy-sequence highlight-words) | ||
| 2220 | (if gnus-newsgroup-name | ||
| 2221 | (copy-sequence (gnus-group-find-parameter | ||
| 2222 | gnus-newsgroup-name 'highlight-words t))) | ||
| 2223 | gnus-emphasis-alist))))) | ||
| 2224 | |||
| 1560 | (defvar gnus-summary-article-menu) | 2225 | (defvar gnus-summary-article-menu) |
| 1561 | (defvar gnus-summary-post-menu) | 2226 | (defvar gnus-summary-post-menu) |
| 1562 | 2227 | ||
| @@ -1576,7 +2241,7 @@ This format is defined by the `gnus-article-time-format' variable." | |||
| 1576 | (if (not gnus-default-article-saver) | 2241 | (if (not gnus-default-article-saver) |
| 1577 | (error "No default saver is defined") | 2242 | (error "No default saver is defined") |
| 1578 | ;; !!! Magic! The saving functions all save | 2243 | ;; !!! Magic! The saving functions all save |
| 1579 | ;; `gnus-original-article-buffer' (or so they think), but we | 2244 | ;; `gnus-save-article-buffer' (or so they think), but we |
| 1580 | ;; bind that variable to our save-buffer. | 2245 | ;; bind that variable to our save-buffer. |
| 1581 | (set-buffer gnus-article-buffer) | 2246 | (set-buffer gnus-article-buffer) |
| 1582 | (let* ((gnus-save-article-buffer save-buffer) | 2247 | (let* ((gnus-save-article-buffer save-buffer) |
| @@ -1662,8 +2327,8 @@ This format is defined by the `gnus-article-time-format' variable." | |||
| 1662 | (gnus-make-directory (file-name-directory file)) | 2327 | (gnus-make-directory (file-name-directory file)) |
| 1663 | ;; If we have read a directory, we append the default file name. | 2328 | ;; If we have read a directory, we append the default file name. |
| 1664 | (when (file-directory-p file) | 2329 | (when (file-directory-p file) |
| 1665 | (setq file (concat (file-name-as-directory file) | 2330 | (setq file (expand-file-name (file-name-nondirectory default-name) |
| 1666 | (file-name-nondirectory default-name)))) | 2331 | (file-name-as-directory file)))) |
| 1667 | ;; Possibly translate some characters. | 2332 | ;; Possibly translate some characters. |
| 1668 | (nnheader-translate-file-chars file))))) | 2333 | (nnheader-translate-file-chars file))))) |
| 1669 | (gnus-make-directory (file-name-directory result)) | 2334 | (gnus-make-directory (file-name-directory result)) |
| @@ -1710,7 +2375,7 @@ Directory to save to is default to `gnus-article-save-directory'." | |||
| 1710 | (widen) | 2375 | (widen) |
| 1711 | (if (and (file-readable-p filename) | 2376 | (if (and (file-readable-p filename) |
| 1712 | (mail-file-babyl-p filename)) | 2377 | (mail-file-babyl-p filename)) |
| 1713 | (gnus-output-to-rmail filename t) | 2378 | (rmail-output-to-rmail-file filename t) |
| 1714 | (gnus-output-to-mail filename))))) | 2379 | (gnus-output-to-mail filename))))) |
| 1715 | filename) | 2380 | filename) |
| 1716 | 2381 | ||
| @@ -1750,8 +2415,7 @@ The directory to save in defaults to `gnus-article-save-directory'." | |||
| 1750 | (save-excursion | 2415 | (save-excursion |
| 1751 | (save-restriction | 2416 | (save-restriction |
| 1752 | (widen) | 2417 | (widen) |
| 1753 | (goto-char (point-min)) | 2418 | (when (article-goto-body) |
| 1754 | (when (search-forward "\n\n" nil t) | ||
| 1755 | (narrow-to-region (point) (point-max))) | 2419 | (narrow-to-region (point) (point-max))) |
| 1756 | (gnus-output-to-file filename)))) | 2420 | (gnus-output-to-file filename)))) |
| 1757 | filename) | 2421 | filename) |
| @@ -1759,7 +2423,8 @@ The directory to save in defaults to `gnus-article-save-directory'." | |||
| 1759 | (defun gnus-summary-save-in-pipe (&optional command) | 2423 | (defun gnus-summary-save-in-pipe (&optional command) |
| 1760 | "Pipe this article to subprocess." | 2424 | "Pipe this article to subprocess." |
| 1761 | (setq command | 2425 | (setq command |
| 1762 | (cond ((eq command 'default) | 2426 | (cond ((and (eq command 'default) |
| 2427 | gnus-last-shell-command) | ||
| 1763 | gnus-last-shell-command) | 2428 | gnus-last-shell-command) |
| 1764 | (command command) | 2429 | (command command) |
| 1765 | (t (read-string | 2430 | (t (read-string |
| @@ -1823,17 +2488,6 @@ If variable `gnus-use-long-file-name' is non-nil, it is | |||
| 1823 | default | 2488 | default |
| 1824 | (or last-file default)))) | 2489 | (or last-file default)))) |
| 1825 | 2490 | ||
| 1826 | (defun gnus-Plain-save-name (newsgroup headers &optional last-file) | ||
| 1827 | "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE. | ||
| 1828 | If variable `gnus-use-long-file-name' is non-nil, it is | ||
| 1829 | ~/News/News.group. Otherwise, it is like ~/News/news/group/news." | ||
| 1830 | (or last-file | ||
| 1831 | (expand-file-name | ||
| 1832 | (if (gnus-use-long-file-name 'not-save) | ||
| 1833 | (gnus-capitalize-newsgroup newsgroup) | ||
| 1834 | (concat (gnus-newsgroup-directory-form newsgroup) "/news")) | ||
| 1835 | gnus-article-save-directory))) | ||
| 1836 | |||
| 1837 | (defun gnus-plain-save-name (newsgroup headers &optional last-file) | 2491 | (defun gnus-plain-save-name (newsgroup headers &optional last-file) |
| 1838 | "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE. | 2492 | "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE. |
| 1839 | If variable `gnus-use-long-file-name' is non-nil, it is | 2493 | If variable `gnus-use-long-file-name' is non-nil, it is |
| @@ -1842,7 +2496,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is | |||
| 1842 | (expand-file-name | 2496 | (expand-file-name |
| 1843 | (if (gnus-use-long-file-name 'not-save) | 2497 | (if (gnus-use-long-file-name 'not-save) |
| 1844 | newsgroup | 2498 | newsgroup |
| 1845 | (concat (gnus-newsgroup-directory-form newsgroup) "/news")) | 2499 | (expand-file-name "news" (gnus-newsgroup-directory-form newsgroup))) |
| 1846 | gnus-article-save-directory))) | 2500 | gnus-article-save-directory))) |
| 1847 | 2501 | ||
| 1848 | (eval-and-compile | 2502 | (eval-and-compile |
| @@ -1854,42 +2508,53 @@ If variable `gnus-use-long-file-name' is non-nil, it is | |||
| 1854 | gfunc (cdr func)) | 2508 | gfunc (cdr func)) |
| 1855 | (setq afunc func | 2509 | (setq afunc func |
| 1856 | gfunc (intern (format "gnus-%s" func)))) | 2510 | gfunc (intern (format "gnus-%s" func)))) |
| 1857 | (fset gfunc | 2511 | (defalias gfunc |
| 1858 | (if (not (fboundp afunc)) | 2512 | (if (fboundp afunc) |
| 1859 | nil | 2513 | `(lambda (&optional interactive &rest args) |
| 1860 | `(lambda (&optional interactive &rest args) | 2514 | ,(documentation afunc t) |
| 1861 | ,(documentation afunc t) | 2515 | (interactive (list t)) |
| 1862 | (interactive (list t)) | 2516 | (save-excursion |
| 1863 | (save-excursion | 2517 | (set-buffer gnus-article-buffer) |
| 1864 | (set-buffer gnus-article-buffer) | 2518 | (if interactive |
| 1865 | (if interactive | 2519 | (call-interactively ',afunc) |
| 1866 | (call-interactively ',afunc) | 2520 | (apply ',afunc args)))))))) |
| 1867 | (apply ',afunc args)))))))) | ||
| 1868 | '(article-hide-headers | 2521 | '(article-hide-headers |
| 1869 | article-hide-boring-headers | 2522 | article-hide-boring-headers |
| 1870 | article-treat-overstrike | 2523 | article-treat-overstrike |
| 1871 | (article-fill . gnus-article-word-wrap) | 2524 | article-fill-long-lines |
| 2525 | article-capitalize-sentences | ||
| 1872 | article-remove-cr | 2526 | article-remove-cr |
| 1873 | article-display-x-face | 2527 | article-display-x-face |
| 1874 | article-de-quoted-unreadable | 2528 | article-de-quoted-unreadable |
| 1875 | article-mime-decode-quoted-printable | 2529 | article-de-base64-unreadable |
| 2530 | article-decode-HZ | ||
| 2531 | article-wash-html | ||
| 2532 | article-hide-list-identifiers | ||
| 1876 | article-hide-pgp | 2533 | article-hide-pgp |
| 2534 | article-strip-banner | ||
| 2535 | article-babel | ||
| 1877 | article-hide-pem | 2536 | article-hide-pem |
| 1878 | article-hide-signature | 2537 | article-hide-signature |
| 2538 | article-strip-headers-in-body | ||
| 1879 | article-remove-trailing-blank-lines | 2539 | article-remove-trailing-blank-lines |
| 1880 | article-strip-leading-blank-lines | 2540 | article-strip-leading-blank-lines |
| 1881 | article-strip-multiple-blank-lines | 2541 | article-strip-multiple-blank-lines |
| 1882 | article-strip-leading-space | 2542 | article-strip-leading-space |
| 2543 | article-strip-trailing-space | ||
| 1883 | article-strip-blank-lines | 2544 | article-strip-blank-lines |
| 1884 | article-strip-all-blank-lines | 2545 | article-strip-all-blank-lines |
| 1885 | article-date-local | 2546 | article-date-local |
| 1886 | article-date-iso8601 | 2547 | article-date-iso8601 |
| 1887 | article-date-original | 2548 | article-date-original |
| 1888 | article-date-ut | 2549 | article-date-ut |
| 2550 | article-decode-mime-words | ||
| 2551 | article-decode-charset | ||
| 2552 | article-decode-encoded-words | ||
| 1889 | article-date-user | 2553 | article-date-user |
| 1890 | article-date-lapsed | 2554 | article-date-lapsed |
| 1891 | article-emphasize | 2555 | article-emphasize |
| 1892 | article-treat-dumbquotes | 2556 | article-treat-dumbquotes |
| 2557 | article-normalize-headers | ||
| 1893 | (article-show-all . gnus-article-show-all-headers)))) | 2558 | (article-show-all . gnus-article-show-all-headers)))) |
| 1894 | 2559 | ||
| 1895 | ;;; | 2560 | ;;; |
| @@ -1898,20 +2563,19 @@ If variable `gnus-use-long-file-name' is non-nil, it is | |||
| 1898 | 2563 | ||
| 1899 | (put 'gnus-article-mode 'mode-class 'special) | 2564 | (put 'gnus-article-mode 'mode-class 'special) |
| 1900 | 2565 | ||
| 2566 | (set-keymap-parent gnus-article-mode-map widget-keymap) | ||
| 2567 | |||
| 1901 | (gnus-define-keys gnus-article-mode-map | 2568 | (gnus-define-keys gnus-article-mode-map |
| 1902 | " " gnus-article-goto-next-page | 2569 | " " gnus-article-goto-next-page |
| 1903 | "\177" gnus-article-goto-prev-page | 2570 | "\177" gnus-article-goto-prev-page |
| 1904 | [delete] gnus-article-goto-prev-page | 2571 | [delete] gnus-article-goto-prev-page |
| 2572 | [backspace] gnus-article-goto-prev-page | ||
| 1905 | "\C-c^" gnus-article-refer-article | 2573 | "\C-c^" gnus-article-refer-article |
| 1906 | "h" gnus-article-show-summary | 2574 | "h" gnus-article-show-summary |
| 1907 | "s" gnus-article-show-summary | 2575 | "s" gnus-article-show-summary |
| 1908 | "\C-c\C-m" gnus-article-mail | 2576 | "\C-c\C-m" gnus-article-mail |
| 1909 | "?" gnus-article-describe-briefly | 2577 | "?" gnus-article-describe-briefly |
| 1910 | gnus-mouse-2 gnus-article-push-button | 2578 | "e" gnus-summary-edit-article |
| 1911 | "\r" gnus-article-press-button | ||
| 1912 | "\t" gnus-article-next-button | ||
| 1913 | "\M-\t" gnus-article-prev-button | ||
| 1914 | "e" gnus-article-edit | ||
| 1915 | "<" beginning-of-buffer | 2579 | "<" beginning-of-buffer |
| 1916 | ">" end-of-buffer | 2580 | ">" end-of-buffer |
| 1917 | "\C-c\C-i" gnus-info-find-node | 2581 | "\C-c\C-i" gnus-info-find-node |
| @@ -1947,7 +2611,10 @@ If variable `gnus-use-long-file-name' is non-nil, it is | |||
| 1947 | ["Hide citation" gnus-article-hide-citation t] | 2611 | ["Hide citation" gnus-article-hide-citation t] |
| 1948 | ["Treat overstrike" gnus-article-treat-overstrike t] | 2612 | ["Treat overstrike" gnus-article-treat-overstrike t] |
| 1949 | ["Remove carriage return" gnus-article-remove-cr t] | 2613 | ["Remove carriage return" gnus-article-remove-cr t] |
| 1950 | ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t])) | 2614 | ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t] |
| 2615 | ["Remove base64" gnus-article-de-base64-unreadable t] | ||
| 2616 | ["Treat html" gnus-article-wash-html t] | ||
| 2617 | ["Decode HZ" gnus-article-decode-HZ t])) | ||
| 1951 | 2618 | ||
| 1952 | ;; Note "Commands" menu is defined in gnus-sum.el for consistency | 2619 | ;; Note "Commands" menu is defined in gnus-sum.el for consistency |
| 1953 | 2620 | ||
| @@ -1979,18 +2646,21 @@ commands: | |||
| 1979 | (setq mode-name "Article") | 2646 | (setq mode-name "Article") |
| 1980 | (setq major-mode 'gnus-article-mode) | 2647 | (setq major-mode 'gnus-article-mode) |
| 1981 | (make-local-variable 'minor-mode-alist) | 2648 | (make-local-variable 'minor-mode-alist) |
| 1982 | (unless (assq 'gnus-show-mime minor-mode-alist) | ||
| 1983 | (push (list 'gnus-show-mime " MIME") minor-mode-alist)) | ||
| 1984 | (use-local-map gnus-article-mode-map) | 2649 | (use-local-map gnus-article-mode-map) |
| 1985 | (gnus-update-format-specifications nil 'article-mode) | 2650 | (gnus-update-format-specifications nil 'article-mode) |
| 1986 | (set (make-local-variable 'page-delimiter) gnus-page-delimiter) | 2651 | (set (make-local-variable 'page-delimiter) gnus-page-delimiter) |
| 1987 | (make-local-variable 'gnus-page-broken) | 2652 | (make-local-variable 'gnus-page-broken) |
| 1988 | (make-local-variable 'gnus-button-marker-list) | 2653 | (make-local-variable 'gnus-button-marker-list) |
| 1989 | (make-local-variable 'gnus-article-current-summary) | 2654 | (make-local-variable 'gnus-article-current-summary) |
| 2655 | (make-local-variable 'gnus-article-mime-handles) | ||
| 2656 | (make-local-variable 'gnus-article-decoded-p) | ||
| 2657 | (make-local-variable 'gnus-article-mime-handle-alist) | ||
| 2658 | (make-local-variable 'gnus-article-wash-types) | ||
| 1990 | (gnus-set-default-directory) | 2659 | (gnus-set-default-directory) |
| 1991 | (buffer-disable-undo (current-buffer)) | 2660 | (buffer-disable-undo) |
| 1992 | (setq buffer-read-only t) | 2661 | (setq buffer-read-only t) |
| 1993 | (set-syntax-table gnus-article-mode-syntax-table) | 2662 | (set-syntax-table gnus-article-mode-syntax-table) |
| 2663 | (mm-enable-multibyte) | ||
| 1994 | (gnus-run-hooks 'gnus-article-mode-hook)) | 2664 | (gnus-run-hooks 'gnus-article-mode-hook)) |
| 1995 | 2665 | ||
| 1996 | (defun gnus-article-setup-buffer () | 2666 | (defun gnus-article-setup-buffer () |
| @@ -2003,6 +2673,7 @@ commands: | |||
| 2003 | (substring name (match-end 0)))))) | 2673 | (substring name (match-end 0)))))) |
| 2004 | (setq gnus-article-buffer name) | 2674 | (setq gnus-article-buffer name) |
| 2005 | (setq gnus-original-article-buffer original) | 2675 | (setq gnus-original-article-buffer original) |
| 2676 | (setq gnus-article-mime-handle-alist nil) | ||
| 2006 | ;; This might be a variable local to the summary buffer. | 2677 | ;; This might be a variable local to the summary buffer. |
| 2007 | (unless gnus-single-article-buffer | 2678 | (unless gnus-single-article-buffer |
| 2008 | (save-excursion | 2679 | (save-excursion |
| @@ -2010,16 +2681,22 @@ commands: | |||
| 2010 | (setq gnus-article-buffer name) | 2681 | (setq gnus-article-buffer name) |
| 2011 | (setq gnus-original-article-buffer original) | 2682 | (setq gnus-original-article-buffer original) |
| 2012 | (gnus-set-global-variables))) | 2683 | (gnus-set-global-variables))) |
| 2684 | (gnus-article-setup-highlight-words) | ||
| 2013 | ;; Init original article buffer. | 2685 | ;; Init original article buffer. |
| 2014 | (save-excursion | 2686 | (save-excursion |
| 2015 | (set-buffer (gnus-get-buffer-create gnus-original-article-buffer)) | 2687 | (set-buffer (gnus-get-buffer-create gnus-original-article-buffer)) |
| 2016 | (buffer-disable-undo (current-buffer)) | 2688 | (mm-enable-multibyte) |
| 2017 | (setq major-mode 'gnus-original-article-mode) | 2689 | (setq major-mode 'gnus-original-article-mode) |
| 2018 | (make-local-variable 'gnus-original-article)) | 2690 | (make-local-variable 'gnus-original-article)) |
| 2019 | (if (get-buffer name) | 2691 | (if (get-buffer name) |
| 2020 | (save-excursion | 2692 | (save-excursion |
| 2021 | (set-buffer name) | 2693 | (set-buffer name) |
| 2022 | (buffer-disable-undo (current-buffer)) | 2694 | (when gnus-article-mime-handles |
| 2695 | (mm-destroy-parts gnus-article-mime-handles) | ||
| 2696 | (setq gnus-article-mime-handles nil)) | ||
| 2697 | ;; Set it to nil in article-buffer! | ||
| 2698 | (setq gnus-article-mime-handle-alist nil) | ||
| 2699 | (buffer-disable-undo) | ||
| 2023 | (setq buffer-read-only t) | 2700 | (setq buffer-read-only t) |
| 2024 | (unless (eq major-mode 'gnus-article-mode) | 2701 | (unless (eq major-mode 'gnus-article-mode) |
| 2025 | (gnus-article-mode)) | 2702 | (gnus-article-mode)) |
| @@ -2028,6 +2705,7 @@ commands: | |||
| 2028 | (set-buffer (gnus-get-buffer-create name)) | 2705 | (set-buffer (gnus-get-buffer-create name)) |
| 2029 | (gnus-article-mode) | 2706 | (gnus-article-mode) |
| 2030 | (make-local-variable 'gnus-summary-buffer) | 2707 | (make-local-variable 'gnus-summary-buffer) |
| 2708 | (gnus-summary-set-local-parameters gnus-newsgroup-name) | ||
| 2031 | (current-buffer))))) | 2709 | (current-buffer))))) |
| 2032 | 2710 | ||
| 2033 | ;; Set article window start at LINE, where LINE is the number of lines | 2711 | ;; Set article window start at LINE, where LINE is the number of lines |
| @@ -2084,8 +2762,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." | |||
| 2084 | (message "Message marked for downloading")) | 2762 | (message "Message marked for downloading")) |
| 2085 | (gnus-summary-mark-article article gnus-canceled-mark) | 2763 | (gnus-summary-mark-article article gnus-canceled-mark) |
| 2086 | (unless (memq article gnus-newsgroup-sparse) | 2764 | (unless (memq article gnus-newsgroup-sparse) |
| 2087 | (gnus-error 1 | 2765 | (gnus-error 1 "No such article (may have expired or been canceled)"))))) |
| 2088 | "No such article (may have expired or been canceled)"))))) | ||
| 2089 | (if (or (eq result 'pseudo) | 2766 | (if (or (eq result 'pseudo) |
| 2090 | (eq result 'nneething)) | 2767 | (eq result 'nneething)) |
| 2091 | (progn | 2768 | (progn |
| @@ -2100,7 +2777,9 @@ If ALL-HEADERS is non-nil, no headers are hidden." | |||
| 2100 | (gnus-configure-windows 'summary) | 2777 | (gnus-configure-windows 'summary) |
| 2101 | (gnus-configure-windows 'article)) | 2778 | (gnus-configure-windows 'article)) |
| 2102 | (gnus-set-global-variables)) | 2779 | (gnus-set-global-variables)) |
| 2103 | (gnus-set-mode-line 'article)) | 2780 | (let ((gnus-article-mime-handle-alist-1 |
| 2781 | gnus-article-mime-handle-alist)) | ||
| 2782 | (gnus-set-mode-line 'article))) | ||
| 2104 | ;; The result from the `request' was an actual article - | 2783 | ;; The result from the `request' was an actual article - |
| 2105 | ;; or at least some text that is now displayed in the | 2784 | ;; or at least some text that is now displayed in the |
| 2106 | ;; article buffer. | 2785 | ;; article buffer. |
| @@ -2131,85 +2810,723 @@ If ALL-HEADERS is non-nil, no headers are hidden." | |||
| 2131 | (when (gnus-visual-p 'article-highlight 'highlight) | 2810 | (when (gnus-visual-p 'article-highlight 'highlight) |
| 2132 | (gnus-run-hooks 'gnus-visual-mark-article-hook)) | 2811 | (gnus-run-hooks 'gnus-visual-mark-article-hook)) |
| 2133 | ;; Set the global newsgroup variables here. | 2812 | ;; Set the global newsgroup variables here. |
| 2134 | ;; Suggested by Jim Sisolak | ||
| 2135 | ;; <sisolak@trans4.neep.wisc.edu>. | ||
| 2136 | (gnus-set-global-variables) | 2813 | (gnus-set-global-variables) |
| 2137 | (setq gnus-have-all-headers | 2814 | (setq gnus-have-all-headers |
| 2138 | (or all-headers gnus-show-all-headers)))) | 2815 | (or all-headers gnus-show-all-headers)))) |
| 2139 | (when (or (numberp article) | 2816 | (when (or (numberp article) |
| 2140 | (stringp article)) | 2817 | (stringp article)) |
| 2141 | ;; Hooks for getting information from the article. | 2818 | (gnus-article-prepare-display) |
| 2142 | ;; This hook must be called before being narrowed. | ||
| 2143 | (let (buffer-read-only) | ||
| 2144 | (gnus-run-hooks 'gnus-tmp-internal-hook) | ||
| 2145 | (gnus-run-hooks 'gnus-article-prepare-hook) | ||
| 2146 | ;; Decode MIME message. | ||
| 2147 | (if gnus-show-mime | ||
| 2148 | (if (or (not gnus-strict-mime) | ||
| 2149 | (gnus-fetch-field "Mime-Version")) | ||
| 2150 | (let ((coding-system-for-write 'binary) | ||
| 2151 | (coding-system-for-read 'binary)) | ||
| 2152 | (funcall gnus-show-mime-method)) | ||
| 2153 | (funcall gnus-decode-encoded-word-method)) | ||
| 2154 | (funcall gnus-show-traditional-method)) | ||
| 2155 | ;; Perform the article display hooks. | ||
| 2156 | (gnus-run-hooks 'gnus-article-display-hook)) | ||
| 2157 | ;; Do page break. | 2819 | ;; Do page break. |
| 2158 | (goto-char (point-min)) | 2820 | (goto-char (point-min)) |
| 2159 | (setq gnus-page-broken | 2821 | (setq gnus-page-broken |
| 2160 | (when gnus-break-pages | 2822 | (when gnus-break-pages |
| 2161 | (gnus-narrow-to-page) | 2823 | (gnus-narrow-to-page) |
| 2162 | t))) | 2824 | t))) |
| 2163 | (gnus-set-mode-line 'article) | 2825 | (let ((gnus-article-mime-handle-alist-1 |
| 2164 | (gnus-configure-windows 'article) | 2826 | gnus-article-mime-handle-alist)) |
| 2165 | (goto-char (point-min)) | 2827 | (gnus-set-mode-line 'article)) |
| 2166 | (search-forward "\n\n" nil t) | 2828 | (article-goto-body) |
| 2167 | (set-window-point (get-buffer-window (current-buffer)) (point)) | 2829 | (set-window-point (get-buffer-window (current-buffer)) (point)) |
| 2830 | (gnus-configure-windows 'article) | ||
| 2168 | t)))))) | 2831 | t)))))) |
| 2169 | 2832 | ||
| 2833 | ;;;###autoload | ||
| 2834 | (defun gnus-article-prepare-display () | ||
| 2835 | "Make the current buffer look like a nice article." | ||
| 2836 | ;; Hooks for getting information from the article. | ||
| 2837 | ;; This hook must be called before being narrowed. | ||
| 2838 | (let ((gnus-article-buffer (current-buffer)) | ||
| 2839 | buffer-read-only) | ||
| 2840 | (unless (eq major-mode 'gnus-article-mode) | ||
| 2841 | (gnus-article-mode)) | ||
| 2842 | (setq buffer-read-only nil | ||
| 2843 | gnus-article-wash-types nil) | ||
| 2844 | (gnus-run-hooks 'gnus-tmp-internal-hook) | ||
| 2845 | (when gnus-display-mime-function | ||
| 2846 | (funcall gnus-display-mime-function)) | ||
| 2847 | (gnus-run-hooks 'gnus-article-prepare-hook))) | ||
| 2848 | |||
| 2849 | ;;; | ||
| 2850 | ;;; Gnus MIME viewing functions | ||
| 2851 | ;;; | ||
| 2852 | |||
| 2853 | (defvar gnus-mime-button-line-format "%{%([%p. %d%T]%)%}%e\n" | ||
| 2854 | "The following specs can be used: | ||
| 2855 | %t The MIME type | ||
| 2856 | %T MIME type, along with additional info | ||
| 2857 | %n The `name' parameter | ||
| 2858 | %d The description, if any | ||
| 2859 | %l The length of the encoded part | ||
| 2860 | %p The part identifier number | ||
| 2861 | %e Dots if the part isn't displayed") | ||
| 2862 | |||
| 2863 | (defvar gnus-mime-button-line-format-alist | ||
| 2864 | '((?t gnus-tmp-type ?s) | ||
| 2865 | (?T gnus-tmp-type-long ?s) | ||
| 2866 | (?n gnus-tmp-name ?s) | ||
| 2867 | (?d gnus-tmp-description ?s) | ||
| 2868 | (?p gnus-tmp-id ?s) | ||
| 2869 | (?l gnus-tmp-length ?d) | ||
| 2870 | (?e gnus-tmp-dots ?s))) | ||
| 2871 | |||
| 2872 | (defvar gnus-mime-button-commands | ||
| 2873 | '((gnus-article-press-button "\r" "Toggle Display") | ||
| 2874 | (gnus-mime-view-part "v" "View Interactively...") | ||
| 2875 | (gnus-mime-view-part-as-type "t" "View As Type...") | ||
| 2876 | (gnus-mime-save-part "o" "Save...") | ||
| 2877 | (gnus-mime-copy-part "c" "View As Text, In Other Buffer") | ||
| 2878 | (gnus-mime-inline-part "i" "View As Text, In This Buffer") | ||
| 2879 | (gnus-mime-internalize-part "E" "View Internally") | ||
| 2880 | (gnus-mime-externalize-part "e" "View Externally") | ||
| 2881 | (gnus-mime-pipe-part "|" "Pipe To Command..."))) | ||
| 2882 | |||
| 2883 | (defun gnus-article-mime-part-status () | ||
| 2884 | (if gnus-article-mime-handle-alist-1 | ||
| 2885 | (format " (%d parts)" (length gnus-article-mime-handle-alist-1)) | ||
| 2886 | "")) | ||
| 2887 | |||
| 2888 | (defvar gnus-mime-button-map | ||
| 2889 | (let ((map (make-sparse-keymap))) | ||
| 2890 | (set-keymap-parent map gnus-article-mode-map) | ||
| 2891 | (define-key map gnus-mouse-2 'gnus-article-push-button) | ||
| 2892 | (define-key map gnus-down-mouse-3 'gnus-mime-button-menu) | ||
| 2893 | (dolist (c gnus-mime-button-commands) | ||
| 2894 | (define-key map (cadr c) (car c))) | ||
| 2895 | map)) | ||
| 2896 | |||
| 2897 | (defun gnus-mime-button-menu (event) | ||
| 2898 | "Construct a context-sensitive menu of MIME commands." | ||
| 2899 | (interactive "e") | ||
| 2900 | (save-excursion | ||
| 2901 | (let ((pos (event-start event))) | ||
| 2902 | (set-buffer (window-buffer (posn-window pos))) | ||
| 2903 | (goto-char (posn-point pos)) | ||
| 2904 | (gnus-article-check-buffer) | ||
| 2905 | (let ((response (x-popup-menu | ||
| 2906 | t `("MIME Part" | ||
| 2907 | ("" ,@(mapcar (lambda (c) | ||
| 2908 | (cons (caddr c) (car c))) | ||
| 2909 | gnus-mime-button-commands)))))) | ||
| 2910 | (if response | ||
| 2911 | (call-interactively response)))))) | ||
| 2912 | |||
| 2913 | (defun gnus-mime-view-all-parts (&optional handles) | ||
| 2914 | "View all the MIME parts." | ||
| 2915 | (interactive) | ||
| 2916 | (save-current-buffer | ||
| 2917 | (set-buffer gnus-article-buffer) | ||
| 2918 | (let ((handles (or handles gnus-article-mime-handles)) | ||
| 2919 | (mail-parse-charset gnus-newsgroup-charset) | ||
| 2920 | (mail-parse-ignored-charsets | ||
| 2921 | (save-excursion (set-buffer gnus-summary-buffer) | ||
| 2922 | gnus-newsgroup-ignored-charsets))) | ||
| 2923 | (if (stringp (car handles)) | ||
| 2924 | (gnus-mime-view-all-parts (cdr handles)) | ||
| 2925 | (mapcar 'mm-display-part handles))))) | ||
| 2926 | |||
| 2927 | (defun gnus-mime-save-part () | ||
| 2928 | "Save the MIME part under point." | ||
| 2929 | (interactive) | ||
| 2930 | (gnus-article-check-buffer) | ||
| 2931 | (let ((data (get-text-property (point) 'gnus-data))) | ||
| 2932 | (mm-save-part data))) | ||
| 2933 | |||
| 2934 | (defun gnus-mime-pipe-part () | ||
| 2935 | "Pipe the MIME part under point to a process." | ||
| 2936 | (interactive) | ||
| 2937 | (gnus-article-check-buffer) | ||
| 2938 | (let ((data (get-text-property (point) 'gnus-data))) | ||
| 2939 | (mm-pipe-part data))) | ||
| 2940 | |||
| 2941 | (defun gnus-mime-view-part () | ||
| 2942 | "Interactively choose a viewing method for the MIME part under point." | ||
| 2943 | (interactive) | ||
| 2944 | (gnus-article-check-buffer) | ||
| 2945 | (let ((data (get-text-property (point) 'gnus-data))) | ||
| 2946 | (mm-interactively-view-part data))) | ||
| 2947 | |||
| 2948 | (defun gnus-mime-view-part-as-type-internal () | ||
| 2949 | (gnus-article-check-buffer) | ||
| 2950 | (let* ((name (mail-content-type-get | ||
| 2951 | (mm-handle-type (get-text-property (point) 'gnus-data)) | ||
| 2952 | 'name)) | ||
| 2953 | (def-type (and name (mm-default-file-encoding name)))) | ||
| 2954 | (and def-type (cons def-type 0)))) | ||
| 2955 | |||
| 2956 | (defun gnus-mime-view-part-as-type (mime-type) | ||
| 2957 | "Choose a MIME media type, and view the part as such." | ||
| 2958 | (interactive | ||
| 2959 | (list (completing-read | ||
| 2960 | "View as MIME type: " | ||
| 2961 | (mapcar #'list (mailcap-mime-types)) | ||
| 2962 | nil nil | ||
| 2963 | (gnus-mime-view-part-as-type-internal)))) | ||
| 2964 | (gnus-article-check-buffer) | ||
| 2965 | (let ((handle (get-text-property (point) 'gnus-data))) | ||
| 2966 | (gnus-mm-display-part | ||
| 2967 | (mm-make-handle (mm-handle-buffer handle) | ||
| 2968 | (cons mime-type (cdr (mm-handle-type handle))) | ||
| 2969 | (mm-handle-encoding handle) | ||
| 2970 | (mm-handle-undisplayer handle) | ||
| 2971 | (mm-handle-disposition handle) | ||
| 2972 | (mm-handle-description handle) | ||
| 2973 | (mm-handle-cache handle) | ||
| 2974 | (mm-handle-id handle))))) | ||
| 2975 | |||
| 2976 | (defun gnus-mime-copy-part (&optional handle) | ||
| 2977 | "Put the the MIME part under point into a new buffer." | ||
| 2978 | (interactive) | ||
| 2979 | (gnus-article-check-buffer) | ||
| 2980 | (let* ((handle (or handle (get-text-property (point) 'gnus-data))) | ||
| 2981 | (contents (mm-get-part handle))| | ||
| 2982 | (base (file-name-nondirectory | ||
| 2983 | (or | ||
| 2984 | (mail-content-type-get (mm-handle-type handle) 'name) | ||
| 2985 | (mail-content-type-get (mm-handle-type handle) | ||
| 2986 | 'filename) | ||
| 2987 | "*decoded*"))) | ||
| 2988 | (buffer (generate-new-buffer base))) | ||
| 2989 | (switch-to-buffer buffer) | ||
| 2990 | (insert contents) | ||
| 2991 | ;; We do it this way to make `normal-mode' set the appropriate mode. | ||
| 2992 | (unwind-protect | ||
| 2993 | (progn | ||
| 2994 | (setq buffer-file-name (expand-file-name base)) | ||
| 2995 | (normal-mode)) | ||
| 2996 | (setq buffer-file-name nil)) | ||
| 2997 | (goto-char (point-min)))) | ||
| 2998 | |||
| 2999 | (defun gnus-mime-inline-part (&optional handle) | ||
| 3000 | "Insert the MIME part under point into the current buffer." | ||
| 3001 | (interactive) | ||
| 3002 | (gnus-article-check-buffer) | ||
| 3003 | (let* ((handle (or handle (get-text-property (point) 'gnus-data))) | ||
| 3004 | contents | ||
| 3005 | (b (point)) | ||
| 3006 | buffer-read-only) | ||
| 3007 | (if (mm-handle-undisplayer handle) | ||
| 3008 | (mm-remove-part handle) | ||
| 3009 | (setq contents (mm-get-part handle)) | ||
| 3010 | (forward-line 2) | ||
| 3011 | (mm-insert-inline handle contents) | ||
| 3012 | (goto-char b)))) | ||
| 3013 | |||
| 3014 | (defun gnus-mime-externalize-part (&optional handle) | ||
| 3015 | "View the MIME part under point with an external viewer." | ||
| 3016 | (interactive) | ||
| 3017 | (gnus-article-check-buffer) | ||
| 3018 | (let* ((handle (or handle (get-text-property (point) 'gnus-data))) | ||
| 3019 | (mm-user-display-methods nil) | ||
| 3020 | (mm-inlined-types nil) | ||
| 3021 | (mail-parse-charset gnus-newsgroup-charset) | ||
| 3022 | (mail-parse-ignored-charsets | ||
| 3023 | (save-excursion (set-buffer gnus-summary-buffer) | ||
| 3024 | gnus-newsgroup-ignored-charsets))) | ||
| 3025 | (if (mm-handle-undisplayer handle) | ||
| 3026 | (mm-remove-part handle) | ||
| 3027 | (mm-display-part handle)))) | ||
| 3028 | |||
| 3029 | (defun gnus-mime-internalize-part (&optional handle) | ||
| 3030 | "View the MIME part under point with an internal viewer. | ||
| 3031 | In no internal viewer is available, use an external viewer." | ||
| 3032 | (interactive) | ||
| 3033 | (gnus-article-check-buffer) | ||
| 3034 | (let* ((handle (or handle (get-text-property (point) 'gnus-data))) | ||
| 3035 | (mm-inlined-types '(".*")) | ||
| 3036 | (mm-inline-large-images t) | ||
| 3037 | (mail-parse-charset gnus-newsgroup-charset) | ||
| 3038 | (mail-parse-ignored-charsets | ||
| 3039 | (save-excursion (set-buffer gnus-summary-buffer) | ||
| 3040 | gnus-newsgroup-ignored-charsets))) | ||
| 3041 | (if (mm-handle-undisplayer handle) | ||
| 3042 | (mm-remove-part handle) | ||
| 3043 | (mm-display-part handle)))) | ||
| 3044 | |||
| 3045 | (defun gnus-article-part-wrapper (n function) | ||
| 3046 | (save-current-buffer | ||
| 3047 | (set-buffer gnus-article-buffer) | ||
| 3048 | (when (> n (length gnus-article-mime-handle-alist)) | ||
| 3049 | (error "No such part")) | ||
| 3050 | (gnus-article-goto-part n) | ||
| 3051 | (let ((handle (cdr (assq n gnus-article-mime-handle-alist)))) | ||
| 3052 | (funcall function handle)))) | ||
| 3053 | |||
| 3054 | (defun gnus-article-pipe-part (n) | ||
| 3055 | "Pipe MIME part N, which is the numerical prefix." | ||
| 3056 | (interactive "p") | ||
| 3057 | (gnus-article-part-wrapper n 'mm-pipe-part)) | ||
| 3058 | |||
| 3059 | (defun gnus-article-save-part (n) | ||
| 3060 | "Save MIME part N, which is the numerical prefix." | ||
| 3061 | (interactive "p") | ||
| 3062 | (gnus-article-part-wrapper n 'mm-save-part)) | ||
| 3063 | |||
| 3064 | (defun gnus-article-interactively-view-part (n) | ||
| 3065 | "View MIME part N interactively, which is the numerical prefix." | ||
| 3066 | (interactive "p") | ||
| 3067 | (gnus-article-part-wrapper n 'mm-interactively-view-part)) | ||
| 3068 | |||
| 3069 | (defun gnus-article-copy-part (n) | ||
| 3070 | "Copy MIME part N, which is the numerical prefix." | ||
| 3071 | (interactive "p") | ||
| 3072 | (gnus-article-part-wrapper n 'gnus-mime-copy-part)) | ||
| 3073 | |||
| 3074 | (defun gnus-article-externalize-part (n) | ||
| 3075 | "View MIME part N externally, which is the numerical prefix." | ||
| 3076 | (interactive "p") | ||
| 3077 | (gnus-article-part-wrapper n 'gnus-mime-externalize-part)) | ||
| 3078 | |||
| 3079 | (defun gnus-article-inline-part (n) | ||
| 3080 | "Inline MIME part N, which is the numerical prefix." | ||
| 3081 | (interactive "p") | ||
| 3082 | (gnus-article-part-wrapper n 'gnus-mime-inline-part)) | ||
| 3083 | |||
| 3084 | (defun gnus-article-mime-match-handle-first (condition) | ||
| 3085 | (if condition | ||
| 3086 | (let ((alist gnus-article-mime-handle-alist) ihandle n) | ||
| 3087 | (while (setq ihandle (pop alist)) | ||
| 3088 | (if (and (cond | ||
| 3089 | ((functionp condition) | ||
| 3090 | (funcall condition (cdr ihandle))) | ||
| 3091 | ((eq condition 'undisplayed) | ||
| 3092 | (not (or (mm-handle-undisplayer (cdr ihandle)) | ||
| 3093 | (equal (mm-handle-media-type (cdr ihandle)) | ||
| 3094 | "multipart/alternative")))) | ||
| 3095 | ((eq condition 'undisplayed-alternative) | ||
| 3096 | (not (mm-handle-undisplayer (cdr ihandle)))) | ||
| 3097 | (t t)) | ||
| 3098 | (gnus-article-goto-part (car ihandle)) | ||
| 3099 | (or (not n) (< (car ihandle) n))) | ||
| 3100 | (setq n (car ihandle)))) | ||
| 3101 | (or n 1)) | ||
| 3102 | 1)) | ||
| 3103 | |||
| 3104 | (defun gnus-article-view-part (&optional n) | ||
| 3105 | "View MIME part N, which is the numerical prefix." | ||
| 3106 | (interactive "P") | ||
| 3107 | (save-current-buffer | ||
| 3108 | (set-buffer gnus-article-buffer) | ||
| 3109 | (or (numberp n) (setq n (gnus-article-mime-match-handle-first | ||
| 3110 | gnus-article-mime-match-handle-function))) | ||
| 3111 | (when (> n (length gnus-article-mime-handle-alist)) | ||
| 3112 | (error "No such part")) | ||
| 3113 | (let ((handle (cdr (assq n gnus-article-mime-handle-alist)))) | ||
| 3114 | (when (gnus-article-goto-part n) | ||
| 3115 | (if (equal (car handle) "multipart/alternative") | ||
| 3116 | (gnus-article-press-button) | ||
| 3117 | (when (eq (gnus-mm-display-part handle) 'internal) | ||
| 3118 | (gnus-set-window-start))))))) | ||
| 3119 | |||
| 3120 | (defun gnus-mm-display-part (handle) | ||
| 3121 | "Display HANDLE and fix MIME button." | ||
| 3122 | (let ((id (get-text-property (point) 'gnus-part)) | ||
| 3123 | (point (point)) | ||
| 3124 | buffer-read-only) | ||
| 3125 | (forward-line 1) | ||
| 3126 | (prog1 | ||
| 3127 | (let ((window (selected-window)) | ||
| 3128 | (mail-parse-charset gnus-newsgroup-charset) | ||
| 3129 | (mail-parse-ignored-charsets | ||
| 3130 | (save-excursion (set-buffer gnus-summary-buffer) | ||
| 3131 | gnus-newsgroup-ignored-charsets))) | ||
| 3132 | (save-excursion | ||
| 3133 | (unwind-protect | ||
| 3134 | (let ((win (get-buffer-window (current-buffer) t)) | ||
| 3135 | (beg (point))) | ||
| 3136 | (when win | ||
| 3137 | (select-window win)) | ||
| 3138 | (goto-char point) | ||
| 3139 | (forward-line) | ||
| 3140 | (if (mm-handle-displayed-p handle) | ||
| 3141 | ;; This will remove the part. | ||
| 3142 | (mm-display-part handle) | ||
| 3143 | (save-restriction | ||
| 3144 | (narrow-to-region (point) (1+ (point))) | ||
| 3145 | (mm-display-part handle) | ||
| 3146 | ;; We narrow to the part itself and | ||
| 3147 | ;; then call the treatment functions. | ||
| 3148 | (goto-char (point-min)) | ||
| 3149 | (forward-line 1) | ||
| 3150 | (narrow-to-region (point) (point-max)) | ||
| 3151 | (gnus-treat-article | ||
| 3152 | nil id | ||
| 3153 | (1- (length gnus-article-mime-handles)) | ||
| 3154 | (mm-handle-media-type handle))))) | ||
| 3155 | (select-window window)))) | ||
| 3156 | (goto-char point) | ||
| 3157 | (delete-region (gnus-point-at-bol) (progn (forward-line 1) (point))) | ||
| 3158 | (gnus-insert-mime-button | ||
| 3159 | handle id (list (mm-handle-displayed-p handle))) | ||
| 3160 | (goto-char point)))) | ||
| 3161 | |||
| 3162 | (defun gnus-article-goto-part (n) | ||
| 3163 | "Go to MIME part N." | ||
| 3164 | (let ((point (text-property-any (point-min) (point-max) 'gnus-part n))) | ||
| 3165 | (when point | ||
| 3166 | (goto-char point)))) | ||
| 3167 | |||
| 3168 | (defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed) | ||
| 3169 | (let ((gnus-tmp-name | ||
| 3170 | (or (mail-content-type-get (mm-handle-type handle) | ||
| 3171 | 'name) | ||
| 3172 | (mail-content-type-get (mm-handle-disposition handle) | ||
| 3173 | 'filename) | ||
| 3174 | "")) | ||
| 3175 | (gnus-tmp-type (mm-handle-media-type handle)) | ||
| 3176 | (gnus-tmp-description | ||
| 3177 | (mail-decode-encoded-word-string (or (mm-handle-description handle) | ||
| 3178 | ""))) | ||
| 3179 | (gnus-tmp-dots | ||
| 3180 | (if (if displayed (car displayed) | ||
| 3181 | (mm-handle-displayed-p handle)) | ||
| 3182 | "" "...")) | ||
| 3183 | (gnus-tmp-length (with-current-buffer (mm-handle-buffer handle) | ||
| 3184 | (buffer-size))) | ||
| 3185 | gnus-tmp-type-long b e) | ||
| 3186 | (when (string-match ".*/" gnus-tmp-name) | ||
| 3187 | (setq gnus-tmp-name (replace-match "" t t gnus-tmp-name))) | ||
| 3188 | (setq gnus-tmp-type-long (concat gnus-tmp-type | ||
| 3189 | (and (not (equal gnus-tmp-name "")) | ||
| 3190 | (concat "; " gnus-tmp-name)))) | ||
| 3191 | (or (equal gnus-tmp-description "") | ||
| 3192 | (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long))) | ||
| 3193 | (unless (bolp) | ||
| 3194 | (insert "\n")) | ||
| 3195 | (setq b (point)) | ||
| 3196 | (gnus-eval-format | ||
| 3197 | gnus-mime-button-line-format gnus-mime-button-line-format-alist | ||
| 3198 | `(local-map ,gnus-mime-button-map | ||
| 3199 | keymap ,gnus-mime-button-map | ||
| 3200 | gnus-callback gnus-mm-display-part | ||
| 3201 | gnus-part ,gnus-tmp-id | ||
| 3202 | article-type annotation | ||
| 3203 | gnus-data ,handle)) | ||
| 3204 | (setq e (point)) | ||
| 3205 | (widget-convert-button | ||
| 3206 | 'link b e | ||
| 3207 | :mime-handle handle | ||
| 3208 | :action 'gnus-widget-press-button | ||
| 3209 | :button-keymap gnus-mime-button-map | ||
| 3210 | :help-echo | ||
| 3211 | (lambda (widget/window &optional overlay pos) | ||
| 3212 | ;; Needed to properly clear the message due to a bug in | ||
| 3213 | ;; wid-edit (XEmacs only). | ||
| 3214 | (if (boundp 'help-echo-owns-message) | ||
| 3215 | (setq help-echo-owns-message t)) | ||
| 3216 | (format | ||
| 3217 | "%S: %s the MIME part; %S: more options" | ||
| 3218 | (aref gnus-mouse-2 0) | ||
| 3219 | ;; XEmacs will get a single widget arg; Emacs 21 will get | ||
| 3220 | ;; window, overlay, position. | ||
| 3221 | (if (mm-handle-displayed-p | ||
| 3222 | (if overlay | ||
| 3223 | (with-current-buffer (overlay-buffer overlay) | ||
| 3224 | (widget-get (widget-at (overlay-start overlay)) | ||
| 3225 | :mime-handle)) | ||
| 3226 | (widget-get widget/window :mime-handle))) | ||
| 3227 | "hide" "show") | ||
| 3228 | (aref gnus-down-mouse-3 0)))))) | ||
| 3229 | |||
| 3230 | (defun gnus-widget-press-button (elems el) | ||
| 3231 | (goto-char (widget-get elems :from)) | ||
| 3232 | (gnus-article-press-button)) | ||
| 3233 | |||
| 3234 | (defvar gnus-displaying-mime nil) | ||
| 3235 | |||
| 3236 | (defun gnus-display-mime (&optional ihandles) | ||
| 3237 | "Display the MIME parts." | ||
| 3238 | (save-excursion | ||
| 3239 | (save-selected-window | ||
| 3240 | (let ((window (get-buffer-window gnus-article-buffer)) | ||
| 3241 | (point (point))) | ||
| 3242 | (when window | ||
| 3243 | (select-window window) | ||
| 3244 | ;; We have to do this since selecting the window | ||
| 3245 | ;; may change the point. So we set the window point. | ||
| 3246 | (set-window-point window point))) | ||
| 3247 | (let* ((handles (or ihandles (mm-dissect-buffer) (mm-uu-dissect))) | ||
| 3248 | buffer-read-only handle name type b e display) | ||
| 3249 | (when (and (not ihandles) | ||
| 3250 | (not gnus-displaying-mime)) | ||
| 3251 | ;; Top-level call; we clean up. | ||
| 3252 | (when gnus-article-mime-handles | ||
| 3253 | (mm-destroy-parts gnus-article-mime-handles) | ||
| 3254 | (setq gnus-article-mime-handle-alist nil));; A trick. | ||
| 3255 | (setq gnus-article-mime-handles handles) | ||
| 3256 | ;; We allow users to glean info from the handles. | ||
| 3257 | (when gnus-article-mime-part-function | ||
| 3258 | (gnus-mime-part-function handles))) | ||
| 3259 | (if (and handles | ||
| 3260 | (or (not (stringp (car handles))) | ||
| 3261 | (cdr handles))) | ||
| 3262 | (progn | ||
| 3263 | (when (and (not ihandles) | ||
| 3264 | (not gnus-displaying-mime)) | ||
| 3265 | ;; Clean up for mime parts. | ||
| 3266 | (article-goto-body) | ||
| 3267 | (delete-region (point) (point-max))) | ||
| 3268 | (let ((gnus-displaying-mime t)) | ||
| 3269 | (gnus-mime-display-part handles))) | ||
| 3270 | (save-restriction | ||
| 3271 | (article-goto-body) | ||
| 3272 | (narrow-to-region (point) (point-max)) | ||
| 3273 | (gnus-treat-article nil 1 1) | ||
| 3274 | (widen))) | ||
| 3275 | (unless ihandles | ||
| 3276 | ;; Highlight the headers. | ||
| 3277 | (save-excursion | ||
| 3278 | (save-restriction | ||
| 3279 | (article-goto-body) | ||
| 3280 | (narrow-to-region (point-min) (point)) | ||
| 3281 | (gnus-treat-article 'head)))))))) | ||
| 3282 | |||
| 3283 | (defvar gnus-mime-display-multipart-as-mixed nil) | ||
| 3284 | |||
| 3285 | (defun gnus-mime-display-part (handle) | ||
| 3286 | (cond | ||
| 3287 | ;; Single part. | ||
| 3288 | ((not (stringp (car handle))) | ||
| 3289 | (gnus-mime-display-single handle)) | ||
| 3290 | ;; User-defined multipart | ||
| 3291 | ((cdr (assoc (car handle) gnus-mime-multipart-functions)) | ||
| 3292 | (funcall (cdr (assoc (car handle) gnus-mime-multipart-functions)) | ||
| 3293 | handle)) | ||
| 3294 | ;; multipart/alternative | ||
| 3295 | ((and (equal (car handle) "multipart/alternative") | ||
| 3296 | (not gnus-mime-display-multipart-as-mixed)) | ||
| 3297 | (let ((id (1+ (length gnus-article-mime-handle-alist)))) | ||
| 3298 | (push (cons id handle) gnus-article-mime-handle-alist) | ||
| 3299 | (gnus-mime-display-alternative (cdr handle) nil nil id))) | ||
| 3300 | ;; multipart/related | ||
| 3301 | ((and (equal (car handle) "multipart/related") | ||
| 3302 | (not gnus-mime-display-multipart-as-mixed)) | ||
| 3303 | ;;;!!!We should find the start part, but we just default | ||
| 3304 | ;;;!!!to the first part. | ||
| 3305 | (gnus-mime-display-part (cadr handle))) | ||
| 3306 | ;; Other multiparts are handled like multipart/mixed. | ||
| 3307 | (t | ||
| 3308 | (gnus-mime-display-mixed (cdr handle))))) | ||
| 3309 | |||
| 3310 | (defun gnus-mime-part-function (handles) | ||
| 3311 | (if (stringp (car handles)) | ||
| 3312 | (mapcar 'gnus-mime-part-function (cdr handles)) | ||
| 3313 | (funcall gnus-article-mime-part-function handles))) | ||
| 3314 | |||
| 3315 | (defun gnus-mime-display-mixed (handles) | ||
| 3316 | (mapcar 'gnus-mime-display-part handles)) | ||
| 3317 | |||
| 3318 | (defun gnus-mime-display-single (handle) | ||
| 3319 | (let ((type (mm-handle-media-type handle)) | ||
| 3320 | (ignored gnus-ignored-mime-types) | ||
| 3321 | (not-attachment t) | ||
| 3322 | (move nil) | ||
| 3323 | display text) | ||
| 3324 | (catch 'ignored | ||
| 3325 | (progn | ||
| 3326 | (while ignored | ||
| 3327 | (when (string-match (pop ignored) type) | ||
| 3328 | (throw 'ignored nil))) | ||
| 3329 | (if (and (setq not-attachment | ||
| 3330 | (and (not (mm-inline-override-p handle)) | ||
| 3331 | (or (not (mm-handle-disposition handle)) | ||
| 3332 | (equal (car (mm-handle-disposition handle)) | ||
| 3333 | "inline") | ||
| 3334 | (mm-attachment-override-p handle)))) | ||
| 3335 | (mm-automatic-display-p handle) | ||
| 3336 | (or (mm-inlined-p handle) | ||
| 3337 | (mm-automatic-external-display-p type))) | ||
| 3338 | (setq display t) | ||
| 3339 | (when (equal (mm-handle-media-supertype handle) "text") | ||
| 3340 | (setq text t))) | ||
| 3341 | (let ((id (1+ (length gnus-article-mime-handle-alist)))) | ||
| 3342 | (push (cons id handle) gnus-article-mime-handle-alist) | ||
| 3343 | (when (or (not display) | ||
| 3344 | (not (gnus-unbuttonized-mime-type-p type))) | ||
| 3345 | ;(gnus-article-insert-newline) | ||
| 3346 | (gnus-insert-mime-button | ||
| 3347 | handle id (list (or display (and not-attachment text)))) | ||
| 3348 | (gnus-article-insert-newline) | ||
| 3349 | ;(gnus-article-insert-newline) | ||
| 3350 | (setq move t))) | ||
| 3351 | (let ((beg (point))) | ||
| 3352 | (cond | ||
| 3353 | (display | ||
| 3354 | (when move | ||
| 3355 | (forward-line -2) | ||
| 3356 | (setq beg (point))) | ||
| 3357 | (let ((mail-parse-charset gnus-newsgroup-charset) | ||
| 3358 | (mail-parse-ignored-charsets | ||
| 3359 | (save-excursion (condition-case () | ||
| 3360 | (set-buffer gnus-summary-buffer) | ||
| 3361 | (error)) | ||
| 3362 | gnus-newsgroup-ignored-charsets))) | ||
| 3363 | (mm-display-part handle t)) | ||
| 3364 | (goto-char (point-max))) | ||
| 3365 | ((and text not-attachment) | ||
| 3366 | (when move | ||
| 3367 | (forward-line -2) | ||
| 3368 | (setq beg (point))) | ||
| 3369 | (gnus-article-insert-newline) | ||
| 3370 | (mm-insert-inline handle (mm-get-part handle)) | ||
| 3371 | (goto-char (point-max)))) | ||
| 3372 | ;; Do highlighting. | ||
| 3373 | (save-excursion | ||
| 3374 | (save-restriction | ||
| 3375 | (narrow-to-region beg (point)) | ||
| 3376 | (gnus-treat-article | ||
| 3377 | nil (length gnus-article-mime-handle-alist) | ||
| 3378 | (1- (length gnus-article-mime-handles)) | ||
| 3379 | (mm-handle-media-type handle))))))))) | ||
| 3380 | |||
| 3381 | (defun gnus-unbuttonized-mime-type-p (type) | ||
| 3382 | "Say whether TYPE is to be unbuttonized." | ||
| 3383 | (unless gnus-inhibit-mime-unbuttonizing | ||
| 3384 | (catch 'found | ||
| 3385 | (let ((types gnus-unbuttonized-mime-types)) | ||
| 3386 | (while types | ||
| 3387 | (when (string-match (pop types) type) | ||
| 3388 | (throw 'found t))))))) | ||
| 3389 | |||
| 3390 | (defun gnus-article-insert-newline () | ||
| 3391 | "Insert a newline, but mark it as undeletable." | ||
| 3392 | (gnus-put-text-property | ||
| 3393 | (point) (progn (insert "\n") (point)) 'gnus-undeletable t)) | ||
| 3394 | |||
| 3395 | (defun gnus-mime-display-alternative (handles &optional preferred ibegend id) | ||
| 3396 | (let* ((preferred (or preferred (mm-preferred-alternative handles))) | ||
| 3397 | (ihandles handles) | ||
| 3398 | (point (point)) | ||
| 3399 | handle buffer-read-only from props begend not-pref) | ||
| 3400 | (save-window-excursion | ||
| 3401 | (save-restriction | ||
| 3402 | (when ibegend | ||
| 3403 | (narrow-to-region (car ibegend) | ||
| 3404 | (or (cdr ibegend) | ||
| 3405 | (progn | ||
| 3406 | (goto-char (car ibegend)) | ||
| 3407 | (forward-line 2) | ||
| 3408 | (point)))) | ||
| 3409 | (delete-region (point-min) (point-max)) | ||
| 3410 | (mm-remove-parts handles)) | ||
| 3411 | (setq begend (list (point-marker))) | ||
| 3412 | ;; Do the toggle. | ||
| 3413 | (unless (setq not-pref (cadr (member preferred ihandles))) | ||
| 3414 | (setq not-pref (car ihandles))) | ||
| 3415 | (when (or ibegend | ||
| 3416 | (not (gnus-unbuttonized-mime-type-p | ||
| 3417 | "multipart/alternative"))) | ||
| 3418 | (gnus-add-text-properties | ||
| 3419 | (setq from (point)) | ||
| 3420 | (progn | ||
| 3421 | (insert (format "%d. " id)) | ||
| 3422 | (point)) | ||
| 3423 | `(gnus-callback | ||
| 3424 | (lambda (handles) | ||
| 3425 | (unless ,(not ibegend) | ||
| 3426 | (setq gnus-article-mime-handle-alist | ||
| 3427 | ',gnus-article-mime-handle-alist)) | ||
| 3428 | (gnus-mime-display-alternative | ||
| 3429 | ',ihandles ',not-pref ',begend ,id)) | ||
| 3430 | local-map ,gnus-mime-button-map | ||
| 3431 | ,gnus-mouse-face-prop ,gnus-article-mouse-face | ||
| 3432 | face ,gnus-article-button-face | ||
| 3433 | keymap ,gnus-mime-button-map | ||
| 3434 | gnus-part ,id | ||
| 3435 | gnus-data ,handle)) | ||
| 3436 | (widget-convert-button 'link from (point) | ||
| 3437 | :action 'gnus-widget-press-button | ||
| 3438 | :button-keymap gnus-widget-button-keymap) | ||
| 3439 | ;; Do the handles | ||
| 3440 | (while (setq handle (pop handles)) | ||
| 3441 | (gnus-add-text-properties | ||
| 3442 | (setq from (point)) | ||
| 3443 | (progn | ||
| 3444 | (insert (format "(%c) %-18s" | ||
| 3445 | (if (equal handle preferred) ?* ? ) | ||
| 3446 | (mm-handle-media-type handle))) | ||
| 3447 | (point)) | ||
| 3448 | `(gnus-callback | ||
| 3449 | (lambda (handles) | ||
| 3450 | (unless ,(not ibegend) | ||
| 3451 | (setq gnus-article-mime-handle-alist | ||
| 3452 | ',gnus-article-mime-handle-alist)) | ||
| 3453 | (gnus-mime-display-alternative | ||
| 3454 | ',ihandles ',handle ',begend ,id)) | ||
| 3455 | local-map ,gnus-mime-button-map | ||
| 3456 | ,gnus-mouse-face-prop ,gnus-article-mouse-face | ||
| 3457 | face ,gnus-article-button-face | ||
| 3458 | keymap ,gnus-mime-button-map | ||
| 3459 | gnus-part ,id | ||
| 3460 | gnus-data ,handle)) | ||
| 3461 | (widget-convert-button 'link from (point) | ||
| 3462 | :action 'gnus-widget-press-button | ||
| 3463 | :button-keymap gnus-widget-button-keymap) | ||
| 3464 | (insert " ")) | ||
| 3465 | (insert "\n\n")) | ||
| 3466 | (when preferred | ||
| 3467 | (if (stringp (car preferred)) | ||
| 3468 | (gnus-display-mime preferred) | ||
| 3469 | (let ((mail-parse-charset gnus-newsgroup-charset) | ||
| 3470 | (mail-parse-ignored-charsets | ||
| 3471 | (save-excursion (set-buffer gnus-summary-buffer) | ||
| 3472 | gnus-newsgroup-ignored-charsets))) | ||
| 3473 | (mm-display-part preferred) | ||
| 3474 | ;; Do highlighting. | ||
| 3475 | (save-excursion | ||
| 3476 | (save-restriction | ||
| 3477 | (narrow-to-region (car begend) (point-max)) | ||
| 3478 | (gnus-treat-article | ||
| 3479 | nil (length gnus-article-mime-handle-alist) | ||
| 3480 | (1- (length gnus-article-mime-handles)) | ||
| 3481 | (mm-handle-media-type handle)))))) | ||
| 3482 | (goto-char (point-max)) | ||
| 3483 | (setcdr begend (point-marker))))) | ||
| 3484 | (when ibegend | ||
| 3485 | (goto-char point)))) | ||
| 3486 | |||
| 2170 | (defun gnus-article-wash-status () | 3487 | (defun gnus-article-wash-status () |
| 2171 | "Return a string which display status of article washing." | 3488 | "Return a string which display status of article washing." |
| 2172 | (save-excursion | 3489 | (save-excursion |
| 2173 | (set-buffer gnus-article-buffer) | 3490 | (set-buffer gnus-article-buffer) |
| 2174 | (let ((cite (gnus-article-hidden-text-p 'cite)) | 3491 | (let ((cite (memq 'cite gnus-article-wash-types)) |
| 2175 | (headers (gnus-article-hidden-text-p 'headers)) | 3492 | (headers (memq 'headers gnus-article-wash-types)) |
| 2176 | (boring (gnus-article-hidden-text-p 'boring-headers)) | 3493 | (boring (memq 'boring-headers gnus-article-wash-types)) |
| 2177 | (pgp (gnus-article-hidden-text-p 'pgp)) | 3494 | (pgp (memq 'pgp gnus-article-wash-types)) |
| 2178 | (pem (gnus-article-hidden-text-p 'pem)) | 3495 | (pem (memq 'pem gnus-article-wash-types)) |
| 2179 | (signature (gnus-article-hidden-text-p 'signature)) | 3496 | (signature (memq 'signature gnus-article-wash-types)) |
| 2180 | (overstrike (gnus-article-hidden-text-p 'overstrike)) | 3497 | (overstrike (memq 'overstrike gnus-article-wash-types)) |
| 2181 | (emphasis (gnus-article-hidden-text-p 'emphasis)) | 3498 | (emphasis (memq 'emphasis gnus-article-wash-types))) |
| 2182 | (mime gnus-show-mime)) | 3499 | (format "%c%c%c%c%c%c" |
| 2183 | (format "%c%c%c%c%c%c%c" | ||
| 2184 | (if cite ?c ? ) | 3500 | (if cite ?c ? ) |
| 2185 | (if (or headers boring) ?h ? ) | 3501 | (if (or headers boring) ?h ? ) |
| 2186 | (if (or pgp pem) ?p ? ) | 3502 | (if (or pgp pem) ?p ? ) |
| 2187 | (if signature ?s ? ) | 3503 | (if signature ?s ? ) |
| 2188 | (if overstrike ?o ? ) | 3504 | (if overstrike ?o ? ) |
| 2189 | (if mime ?m ? ) | ||
| 2190 | (if emphasis ?e ? ))))) | 3505 | (if emphasis ?e ? ))))) |
| 2191 | 3506 | ||
| 2192 | (fset 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers) | 3507 | (defalias 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers) |
| 2193 | 3508 | ||
| 2194 | (defun gnus-article-maybe-hide-headers () | 3509 | (defun gnus-article-maybe-hide-headers () |
| 2195 | "Hide unwanted headers if `gnus-have-all-headers' is nil. | 3510 | "Hide unwanted headers if `gnus-have-all-headers' is nil. |
| 2196 | Provided for backwards compatibility." | 3511 | Provided for backwards compatibility." |
| 2197 | (or (save-excursion (set-buffer gnus-summary-buffer) gnus-have-all-headers) | 3512 | (when (and (or (not (gnus-buffer-live-p gnus-summary-buffer)) |
| 2198 | gnus-inhibit-hiding | 3513 | (not (save-excursion (set-buffer gnus-summary-buffer) |
| 2199 | (gnus-article-hide-headers))) | 3514 | gnus-have-all-headers))) |
| 3515 | (not gnus-inhibit-hiding)) | ||
| 3516 | (gnus-article-hide-headers))) | ||
| 2200 | 3517 | ||
| 2201 | ;;; Article savers. | 3518 | ;;; Article savers. |
| 2202 | 3519 | ||
| 2203 | (defun gnus-output-to-file (file-name) | 3520 | (defun gnus-output-to-file (file-name) |
| 2204 | "Append the current article to a file named FILE-NAME." | 3521 | "Append the current article to a file named FILE-NAME." |
| 2205 | (let ((artbuf (current-buffer))) | 3522 | (let ((artbuf (current-buffer))) |
| 2206 | (nnheader-temp-write nil | 3523 | (with-temp-buffer |
| 2207 | (insert-buffer-substring artbuf) | 3524 | (insert-buffer-substring artbuf) |
| 2208 | ;; Append newline at end of the buffer as separator, and then | 3525 | ;; Append newline at end of the buffer as separator, and then |
| 2209 | ;; save it to file. | 3526 | ;; save it to file. |
| 2210 | (goto-char (point-max)) | 3527 | (goto-char (point-max)) |
| 2211 | (insert "\n") | 3528 | (insert "\n") |
| 2212 | (append-to-file (point-min) (point-max) file-name) | 3529 | (mm-append-to-file (point-min) (point-max) file-name) |
| 2213 | t))) | 3530 | t))) |
| 2214 | 3531 | ||
| 2215 | (defun gnus-narrow-to-page (&optional arg) | 3532 | (defun gnus-narrow-to-page (&optional arg) |
| @@ -2337,8 +3654,7 @@ Argument LINES specifies lines to be scrolled down." | |||
| 2337 | (defun gnus-article-describe-briefly () | 3654 | (defun gnus-article-describe-briefly () |
| 2338 | "Describe article mode commands briefly." | 3655 | "Describe article mode commands briefly." |
| 2339 | (interactive) | 3656 | (interactive) |
| 2340 | (gnus-message 6 | 3657 | (gnus-message 6 (substitute-command-keys "\\<gnus-article-mode-map>\\[gnus-article-goto-next-page]:Next page \\[gnus-article-goto-prev-page]:Prev page \\[gnus-article-show-summary]:Show summary \\[gnus-info-find-node]:Run Info \\[gnus-article-describe-briefly]:This help"))) |
| 2341 | (substitute-command-keys "\\<gnus-article-mode-map>\\[gnus-article-goto-next-page]:Next page \\[gnus-article-goto-prev-page]:Prev page \\[gnus-article-show-summary]:Show summary \\[gnus-info-find-node]:Run Info \\[gnus-article-describe-briefly]:This help"))) | ||
| 2342 | 3658 | ||
| 2343 | (defun gnus-article-summary-command () | 3659 | (defun gnus-article-summary-command () |
| 2344 | "Execute the last keystroke in the summary buffer." | 3660 | "Execute the last keystroke in the summary buffer." |
| @@ -2361,9 +3677,15 @@ Argument LINES specifies lines to be scrolled down." | |||
| 2361 | (setq func (lookup-key (current-local-map) (this-command-keys))) | 3677 | (setq func (lookup-key (current-local-map) (this-command-keys))) |
| 2362 | (call-interactively func))) | 3678 | (call-interactively func))) |
| 2363 | 3679 | ||
| 3680 | (defun gnus-article-check-buffer () | ||
| 3681 | "Beep if not in an article buffer." | ||
| 3682 | (unless (equal major-mode 'gnus-article-mode) | ||
| 3683 | (error "Command invoked outside of a Gnus article buffer"))) | ||
| 3684 | |||
| 2364 | (defun gnus-article-read-summary-keys (&optional arg key not-restore-window) | 3685 | (defun gnus-article-read-summary-keys (&optional arg key not-restore-window) |
| 2365 | "Read a summary buffer key sequence and execute it from the article buffer." | 3686 | "Read a summary buffer key sequence and execute it from the article buffer." |
| 2366 | (interactive "P") | 3687 | (interactive "P") |
| 3688 | (gnus-article-check-buffer) | ||
| 2367 | (let ((nosaves | 3689 | (let ((nosaves |
| 2368 | '("q" "Q" "c" "r" "R" "\C-c\C-f" "m" "a" "f" "F" | 3690 | '("q" "Q" "c" "r" "R" "\C-c\C-f" "m" "a" "f" "F" |
| 2369 | "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP" | 3691 | "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP" |
| @@ -2379,7 +3701,10 @@ Argument LINES specifies lines to be scrolled down." | |||
| 2379 | (set-buffer gnus-article-current-summary) | 3701 | (set-buffer gnus-article-current-summary) |
| 2380 | (let (gnus-pick-mode) | 3702 | (let (gnus-pick-mode) |
| 2381 | (push (or key last-command-event) unread-command-events) | 3703 | (push (or key last-command-event) unread-command-events) |
| 2382 | (setq keys (read-key-sequence nil)))) | 3704 | (setq keys (if gnus-xemacs |
| 3705 | (events-to-keys (read-key-sequence nil)) | ||
| 3706 | (read-key-sequence nil))))) | ||
| 3707 | |||
| 2383 | (message "") | 3708 | (message "") |
| 2384 | 3709 | ||
| 2385 | (if (or (member keys nosaves) | 3710 | (if (or (member keys nosaves) |
| @@ -2391,7 +3716,8 @@ Argument LINES specifies lines to be scrolled down." | |||
| 2391 | ;; We disable the pick minor mode commands. | 3716 | ;; We disable the pick minor mode commands. |
| 2392 | (let (gnus-pick-mode) | 3717 | (let (gnus-pick-mode) |
| 2393 | (setq func (lookup-key (current-local-map) keys)))) | 3718 | (setq func (lookup-key (current-local-map) keys)))) |
| 2394 | (if (not func) | 3719 | (if (or (not func) |
| 3720 | (numberp func)) | ||
| 2395 | (ding) | 3721 | (ding) |
| 2396 | (unless (member keys nosave-in-article) | 3722 | (unless (member keys nosave-in-article) |
| 2397 | (set-buffer gnus-article-current-summary)) | 3723 | (set-buffer gnus-article-current-summary)) |
| @@ -2421,9 +3747,12 @@ Argument LINES specifies lines to be scrolled down." | |||
| 2421 | (set-buffer obuf) | 3747 | (set-buffer obuf) |
| 2422 | (unless not-restore-window | 3748 | (unless not-restore-window |
| 2423 | (set-window-configuration owin)) | 3749 | (set-window-configuration owin)) |
| 2424 | (unless (or (not (eq selected 'old)) (member keys up-to-top)) | 3750 | (when (eq selected 'old) |
| 3751 | (article-goto-body) | ||
| 3752 | (set-window-start (get-buffer-window (current-buffer)) | ||
| 3753 | 1) | ||
| 2425 | (set-window-point (get-buffer-window (current-buffer)) | 3754 | (set-window-point (get-buffer-window (current-buffer)) |
| 2426 | opoint)) | 3755 | (point))) |
| 2427 | (let ((win (get-buffer-window gnus-article-current-summary))) | 3756 | (let ((win (get-buffer-window gnus-article-current-summary))) |
| 2428 | (when win | 3757 | (when win |
| 2429 | (set-window-point win new-sum-point)))))))) | 3758 | (set-window-point win new-sum-point)))))))) |
| @@ -2435,6 +3764,7 @@ headers will be hidden. | |||
| 2435 | If given a prefix, show the hidden text instead." | 3764 | If given a prefix, show the hidden text instead." |
| 2436 | (interactive (append (gnus-article-hidden-arg) (list 'force))) | 3765 | (interactive (append (gnus-article-hidden-arg) (list 'force))) |
| 2437 | (gnus-article-hide-headers arg) | 3766 | (gnus-article-hide-headers arg) |
| 3767 | (gnus-article-hide-list-identifiers arg) | ||
| 2438 | (gnus-article-hide-pgp arg) | 3768 | (gnus-article-hide-pgp arg) |
| 2439 | (gnus-article-hide-citation-maybe arg force) | 3769 | (gnus-article-hide-citation-maybe arg force) |
| 2440 | (gnus-article-hide-signature arg)) | 3770 | (gnus-article-hide-signature arg)) |
| @@ -2467,8 +3797,7 @@ If given a prefix, show the hidden text instead." | |||
| 2467 | ;; We only request an article by message-id when we do not have the | 3797 | ;; We only request an article by message-id when we do not have the |
| 2468 | ;; headers for it, so we'll have to get those. | 3798 | ;; headers for it, so we'll have to get those. |
| 2469 | (when (stringp article) | 3799 | (when (stringp article) |
| 2470 | (let ((gnus-override-method gnus-refer-article-method)) | 3800 | (gnus-read-header article)) |
| 2471 | (gnus-read-header article))) | ||
| 2472 | 3801 | ||
| 2473 | ;; If the article number is negative, that means that this article | 3802 | ;; If the article number is negative, that means that this article |
| 2474 | ;; doesn't belong in this newsgroup (possibly), so we find its | 3803 | ;; doesn't belong in this newsgroup (possibly), so we find its |
| @@ -2486,8 +3815,7 @@ If given a prefix, show the hidden text instead." | |||
| 2486 | ;; This is a sparse gap article. | 3815 | ;; This is a sparse gap article. |
| 2487 | (setq do-update-line article) | 3816 | (setq do-update-line article) |
| 2488 | (setq article (mail-header-id header)) | 3817 | (setq article (mail-header-id header)) |
| 2489 | (let ((gnus-override-method gnus-refer-article-method)) | 3818 | (setq sparse-header (gnus-read-header article)) |
| 2490 | (setq sparse-header (gnus-read-header article))) | ||
| 2491 | (setq gnus-newsgroup-sparse | 3819 | (setq gnus-newsgroup-sparse |
| 2492 | (delq article gnus-newsgroup-sparse))) | 3820 | (delq article gnus-newsgroup-sparse))) |
| 2493 | ((vectorp header) | 3821 | ((vectorp header) |
| @@ -2502,11 +3830,11 @@ If given a prefix, show the hidden text instead." | |||
| 2502 | gnus-newsgroup-name))) | 3830 | gnus-newsgroup-name))) |
| 2503 | (when (and (eq (car method) 'nneething) | 3831 | (when (and (eq (car method) 'nneething) |
| 2504 | (vectorp header)) | 3832 | (vectorp header)) |
| 2505 | (let ((dir (concat | 3833 | (let ((dir (expand-file-name |
| 3834 | (mail-header-subject header) | ||
| 2506 | (file-name-as-directory | 3835 | (file-name-as-directory |
| 2507 | (or (cadr (assq 'nneething-address method)) | 3836 | (or (cadr (assq 'nneething-address method)) |
| 2508 | (nth 1 method))) | 3837 | (nth 1 method)))))) |
| 2509 | (mail-header-subject header)))) | ||
| 2510 | (when (file-directory-p dir) | 3838 | (when (file-directory-p dir) |
| 2511 | (setq article 'nneething) | 3839 | (setq article 'nneething) |
| 2512 | (gnus-group-enter-directory dir)))))))) | 3840 | (gnus-group-enter-directory dir)))))))) |
| @@ -2547,20 +3875,40 @@ If given a prefix, show the hidden text instead." | |||
| 2547 | (gnus-cache-request-article article group)) | 3875 | (gnus-cache-request-article article group)) |
| 2548 | 'article) | 3876 | 'article) |
| 2549 | ;; Get the article and put into the article buffer. | 3877 | ;; Get the article and put into the article buffer. |
| 2550 | ((or (stringp article) (numberp article)) | 3878 | ((or (stringp article) |
| 2551 | (let ((gnus-override-method | 3879 | (numberp article)) |
| 2552 | (and (stringp article) gnus-refer-article-method)) | 3880 | (let ((gnus-override-method gnus-override-method) |
| 3881 | (methods (and (stringp article) | ||
| 3882 | gnus-refer-article-method)) | ||
| 3883 | result | ||
| 2553 | (buffer-read-only nil)) | 3884 | (buffer-read-only nil)) |
| 2554 | (erase-buffer) | 3885 | (setq methods |
| 2555 | (gnus-kill-all-overlays) | 3886 | (if (listp methods) |
| 2556 | (gnus-check-group-server) | 3887 | methods |
| 2557 | (when (gnus-request-article article group (current-buffer)) | 3888 | (list methods))) |
| 2558 | (when (numberp article) | 3889 | (when (and (null gnus-override-method) |
| 2559 | (gnus-async-prefetch-next group article gnus-summary-buffer) | 3890 | methods) |
| 2560 | (when gnus-keep-backlog | 3891 | (setq gnus-override-method (pop methods))) |
| 2561 | (gnus-backlog-enter-article | 3892 | (while (not result) |
| 2562 | group article (current-buffer)))) | 3893 | (when (eq gnus-override-method 'current) |
| 2563 | 'article))) | 3894 | (setq gnus-override-method gnus-current-select-method)) |
| 3895 | (erase-buffer) | ||
| 3896 | (gnus-kill-all-overlays) | ||
| 3897 | (let ((gnus-newsgroup-name group)) | ||
| 3898 | (gnus-check-group-server)) | ||
| 3899 | (when (gnus-request-article article group (current-buffer)) | ||
| 3900 | (when (numberp article) | ||
| 3901 | (gnus-async-prefetch-next group article | ||
| 3902 | gnus-summary-buffer) | ||
| 3903 | (when gnus-keep-backlog | ||
| 3904 | (gnus-backlog-enter-article | ||
| 3905 | group article (current-buffer)))) | ||
| 3906 | (setq result 'article)) | ||
| 3907 | (if (not result) | ||
| 3908 | (if methods | ||
| 3909 | (setq gnus-override-method (pop methods)) | ||
| 3910 | (setq result 'done)))) | ||
| 3911 | (and (eq result 'article) 'article))) | ||
| 2564 | ;; It was a pseudo. | 3912 | ;; It was a pseudo. |
| 2565 | (t article))) | 3913 | (t article))) |
| 2566 | 3914 | ||
| @@ -2576,13 +3924,18 @@ If given a prefix, show the hidden text instead." | |||
| 2576 | (if (get-buffer gnus-original-article-buffer) | 3924 | (if (get-buffer gnus-original-article-buffer) |
| 2577 | (set-buffer gnus-original-article-buffer) | 3925 | (set-buffer gnus-original-article-buffer) |
| 2578 | (set-buffer (gnus-get-buffer-create gnus-original-article-buffer)) | 3926 | (set-buffer (gnus-get-buffer-create gnus-original-article-buffer)) |
| 2579 | (buffer-disable-undo (current-buffer)) | 3927 | (buffer-disable-undo) |
| 2580 | (setq major-mode 'gnus-original-article-mode) | 3928 | (setq major-mode 'gnus-original-article-mode) |
| 2581 | (setq buffer-read-only t)) | 3929 | (setq buffer-read-only t)) |
| 2582 | (let (buffer-read-only) | 3930 | (let (buffer-read-only) |
| 2583 | (erase-buffer) | 3931 | (erase-buffer) |
| 2584 | (insert-buffer-substring gnus-article-buffer)) | 3932 | (insert-buffer-substring gnus-article-buffer)) |
| 2585 | (setq gnus-original-article (cons group article)))) | 3933 | (setq gnus-original-article (cons group article))) |
| 3934 | |||
| 3935 | ;; Decode charsets. | ||
| 3936 | (run-hooks 'gnus-article-decode-hook) | ||
| 3937 | ;; Mark article as decoded or not. | ||
| 3938 | (setq gnus-article-decoded-p gnus-article-decode-hook)) | ||
| 2586 | 3939 | ||
| 2587 | ;; Update sparse articles. | 3940 | ;; Update sparse articles. |
| 2588 | (when (and do-update-line | 3941 | (when (and do-update-line |
| @@ -2609,8 +3962,10 @@ If given a prefix, show the hidden text instead." | |||
| 2609 | 3962 | ||
| 2610 | (defvar gnus-article-edit-mode-map nil) | 3963 | (defvar gnus-article-edit-mode-map nil) |
| 2611 | 3964 | ||
| 3965 | ;; Should we be using derived.el for this? | ||
| 2612 | (unless gnus-article-edit-mode-map | 3966 | (unless gnus-article-edit-mode-map |
| 2613 | (setq gnus-article-edit-mode-map (copy-keymap text-mode-map)) | 3967 | (setq gnus-article-edit-mode-map (make-sparse-keymap)) |
| 3968 | (set-keymap-parent gnus-article-edit-mode-map text-mode-map) | ||
| 2614 | 3969 | ||
| 2615 | (gnus-define-keys gnus-article-edit-mode-map | 3970 | (gnus-define-keys gnus-article-edit-mode-map |
| 2616 | "\C-c\C-c" gnus-article-edit-done | 3971 | "\C-c\C-c" gnus-article-edit-done |
| @@ -2647,18 +4002,19 @@ groups." | |||
| 2647 | (error "The current newsgroup does not support article editing")) | 4002 | (error "The current newsgroup does not support article editing")) |
| 2648 | (gnus-article-date-original) | 4003 | (gnus-article-date-original) |
| 2649 | (gnus-article-edit-article | 4004 | (gnus-article-edit-article |
| 4005 | 'ignore | ||
| 2650 | `(lambda (no-highlight) | 4006 | `(lambda (no-highlight) |
| 4007 | 'ignore | ||
| 2651 | (gnus-summary-edit-article-done | 4008 | (gnus-summary-edit-article-done |
| 2652 | ,(or (mail-header-references gnus-current-headers) "") | 4009 | ,(or (mail-header-references gnus-current-headers) "") |
| 2653 | ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight)))) | 4010 | ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight)))) |
| 2654 | 4011 | ||
| 2655 | (defun gnus-article-edit-article (exit-func) | 4012 | (defun gnus-article-edit-article (start-func exit-func) |
| 2656 | "Start editing the contents of the current article buffer." | 4013 | "Start editing the contents of the current article buffer." |
| 2657 | (let ((winconf (current-window-configuration))) | 4014 | (let ((winconf (current-window-configuration))) |
| 2658 | (set-buffer gnus-article-buffer) | 4015 | (set-buffer gnus-article-buffer) |
| 2659 | (gnus-article-edit-mode) | 4016 | (gnus-article-edit-mode) |
| 2660 | (gnus-article-delete-text-of-type 'annotation) | 4017 | (funcall start-func) |
| 2661 | (gnus-set-text-properties (point-min) (point-max) nil) | ||
| 2662 | (gnus-configure-windows 'edit-article) | 4018 | (gnus-configure-windows 'edit-article) |
| 2663 | (setq gnus-article-edit-done-function exit-func) | 4019 | (setq gnus-article-edit-done-function exit-func) |
| 2664 | (setq gnus-prev-winconf winconf) | 4020 | (setq gnus-prev-winconf winconf) |
| @@ -2670,8 +4026,7 @@ groups." | |||
| 2670 | (save-excursion | 4026 | (save-excursion |
| 2671 | (save-restriction | 4027 | (save-restriction |
| 2672 | (widen) | 4028 | (widen) |
| 2673 | (goto-char (point-min)) | 4029 | (when (article-goto-body) |
| 2674 | (when (search-forward "\n\n" nil 1) | ||
| 2675 | (let ((lines (count-lines (point) (point-max))) | 4030 | (let ((lines (count-lines (point) (point-max))) |
| 2676 | (length (- (point-max) (point))) | 4031 | (length (- (point-max) (point))) |
| 2677 | (case-fold-search t) | 4032 | (case-fold-search t) |
| @@ -2696,7 +4051,19 @@ groups." | |||
| 2696 | (save-excursion | 4051 | (save-excursion |
| 2697 | (set-buffer buf) | 4052 | (set-buffer buf) |
| 2698 | (let ((buffer-read-only nil)) | 4053 | (let ((buffer-read-only nil)) |
| 2699 | (funcall func arg))) | 4054 | (funcall func arg)) |
| 4055 | ;; The cache and backlog have to be flushed somewhat. | ||
| 4056 | (when gnus-keep-backlog | ||
| 4057 | (gnus-backlog-remove-article | ||
| 4058 | (car gnus-article-current) (cdr gnus-article-current))) | ||
| 4059 | ;; Flush original article as well. | ||
| 4060 | (save-excursion | ||
| 4061 | (when (get-buffer gnus-original-article-buffer) | ||
| 4062 | (set-buffer gnus-original-article-buffer) | ||
| 4063 | (setq gnus-original-article nil))) | ||
| 4064 | (when gnus-use-cache | ||
| 4065 | (gnus-cache-update-article | ||
| 4066 | (car gnus-article-current) (cdr gnus-article-current)))) | ||
| 2700 | (set-buffer buf) | 4067 | (set-buffer buf) |
| 2701 | (set-window-start (get-buffer-window buf) start) | 4068 | (set-window-start (get-buffer-window buf) start) |
| 2702 | (set-window-point (get-buffer-window buf) (point)))) | 4069 | (set-window-point (get-buffer-window buf) (point)))) |
| @@ -2705,7 +4072,7 @@ groups." | |||
| 2705 | "Exit the article editing without updating." | 4072 | "Exit the article editing without updating." |
| 2706 | (interactive) | 4073 | (interactive) |
| 2707 | ;; We remove all text props from the article buffer. | 4074 | ;; We remove all text props from the article buffer. |
| 2708 | (let ((buf (format "%s" (buffer-string))) | 4075 | (let ((buf (buffer-substring-no-properties (point-min) (point-max))) |
| 2709 | (curbuf (current-buffer)) | 4076 | (curbuf (current-buffer)) |
| 2710 | (p (point)) | 4077 | (p (point)) |
| 2711 | (window-start (window-start))) | 4078 | (window-start (window-start))) |
| @@ -2713,25 +4080,12 @@ groups." | |||
| 2713 | (insert buf) | 4080 | (insert buf) |
| 2714 | (let ((winconf gnus-prev-winconf)) | 4081 | (let ((winconf gnus-prev-winconf)) |
| 2715 | (gnus-article-mode) | 4082 | (gnus-article-mode) |
| 2716 | ;; The cache and backlog have to be flushed somewhat. | ||
| 2717 | (when gnus-use-cache | ||
| 2718 | (gnus-cache-update-article | ||
| 2719 | (car gnus-article-current) (cdr gnus-article-current))) | ||
| 2720 | (when gnus-keep-backlog | ||
| 2721 | (gnus-backlog-remove-article | ||
| 2722 | (car gnus-article-current) (cdr gnus-article-current))) | ||
| 2723 | ;; Flush original article as well. | ||
| 2724 | (save-excursion | ||
| 2725 | (when (get-buffer gnus-original-article-buffer) | ||
| 2726 | (set-buffer gnus-original-article-buffer) | ||
| 2727 | (setq gnus-original-article nil))) | ||
| 2728 | (set-window-configuration winconf) | 4083 | (set-window-configuration winconf) |
| 2729 | ;; Tippy-toe some to make sure that point remains where it was. | 4084 | ;; Tippy-toe some to make sure that point remains where it was. |
| 2730 | (let ((buf (current-buffer))) | 4085 | (save-current-buffer |
| 2731 | (set-buffer curbuf) | 4086 | (set-buffer curbuf) |
| 2732 | (set-window-start (get-buffer-window (current-buffer)) window-start) | 4087 | (set-window-start (get-buffer-window (current-buffer)) window-start) |
| 2733 | (goto-char p) | 4088 | (goto-char p))))) |
| 2734 | (set-buffer buf))))) | ||
| 2735 | 4089 | ||
| 2736 | (defun gnus-article-edit-full-stops () | 4090 | (defun gnus-article-edit-full-stops () |
| 2737 | "Interactively repair spacing at end of sentences." | 4091 | "Interactively repair spacing at end of sentences." |
| @@ -2750,15 +4104,15 @@ groups." | |||
| 2750 | 4104 | ||
| 2751 | ;;; Internal Variables: | 4105 | ;;; Internal Variables: |
| 2752 | 4106 | ||
| 2753 | (defcustom gnus-button-url-regexp "\\b\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?\\([-a-zA-Z0-9_=!?#$@~`%&*+|\\/:;.,]\\|\\w\\)+\\([-a-zA-Z0-9_=#$@~`%&*+|\\/]\\|\\w\\)" | 4107 | (defcustom gnus-button-url-regexp "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\)\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?\\([-a-zA-Z0-9_=!?#$@~`%&*+|\\/:;.,]\\|\\w\\)+\\([-a-zA-Z0-9_=#$@~`%&*+|\\/]\\|\\w\\)\\)" |
| 2754 | "Regular expression that matches URLs." | 4108 | "Regular expression that matches URLs." |
| 2755 | :group 'gnus-article-buttons | 4109 | :group 'gnus-article-buttons |
| 2756 | :type 'regexp) | 4110 | :type 'regexp) |
| 2757 | 4111 | ||
| 2758 | (defcustom gnus-button-alist | 4112 | (defcustom gnus-button-alist |
| 2759 | `(("<\\(url:[>\n\t ]*?\\)?news:[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>" 0 t | 4113 | `(("<\\(url:[>\n\t ]*?\\)?news:[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>" |
| 2760 | gnus-button-message-id 2) | 4114 | 0 t gnus-button-message-id 2) |
| 2761 | ("\\bnews:\\([^>\n\t ]*@[^>\n\t ]*\\)" 0 t gnus-button-message-id 1) | 4115 | ("\\bnews:\\([^>\n\t ]*@[^>)!;:,\n\t ]*\\)" 0 t gnus-button-message-id 1) |
| 2762 | ("\\(\\b<\\(url:[>\n\t ]*\\)?news:[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)" | 4116 | ("\\(\\b<\\(url:[>\n\t ]*\\)?news:[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)" |
| 2763 | 1 t | 4117 | 1 t |
| 2764 | gnus-button-fetch-group 4) | 4118 | gnus-button-fetch-group 4) |
| @@ -2766,12 +4120,12 @@ groups." | |||
| 2766 | ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2 | 4120 | ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2 |
| 2767 | t gnus-button-message-id 3) | 4121 | t gnus-button-message-id 3) |
| 2768 | ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>" 0 t gnus-url-mailto 2) | 4122 | ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>" 0 t gnus-url-mailto 2) |
| 2769 | ("mailto:\\([a-zA-Z.-@_+0-9%]+\\)" 0 t gnus-url-mailto 1) | 4123 | ("mailto:\\([-a-zA-Z.@_+0-9%]+\\)" 0 t gnus-url-mailto 1) |
| 2770 | ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1) | 4124 | ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1) |
| 2771 | ;; This is how URLs _should_ be embedded in text... | 4125 | ;; This is how URLs _should_ be embedded in text... |
| 2772 | ("<URL: *\\([^>]*\\)>" 0 t gnus-button-embedded-url 1) | 4126 | ("<URL: *\\([^<>]*\\)>" 0 t gnus-button-embedded-url 1) |
| 2773 | ;; Raw URLs. | 4127 | ;; Raw URLs. |
| 2774 | (,gnus-button-url-regexp 0 t gnus-button-url 0)) | 4128 | (,gnus-button-url-regexp 0 t browse-url 0)) |
| 2775 | "*Alist of regexps matching buttons in article bodies. | 4129 | "*Alist of regexps matching buttons in article bodies. |
| 2776 | 4130 | ||
| 2777 | Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where | 4131 | Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where |
| @@ -2799,9 +4153,9 @@ variable it the real callback function." | |||
| 2799 | ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 t gnus-button-reply 1) | 4153 | ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 t gnus-button-reply 1) |
| 2800 | ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+" | 4154 | ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+" |
| 2801 | 0 t gnus-button-mailto 0) | 4155 | 0 t gnus-button-mailto 0) |
| 2802 | ("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t gnus-button-url 0) | 4156 | ("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t browse-url 0) |
| 2803 | ("^Subject:" ,gnus-button-url-regexp 0 t gnus-button-url 0) | 4157 | ("^Subject:" ,gnus-button-url-regexp 0 t browse-url 0) |
| 2804 | ("^[^:]+:" ,gnus-button-url-regexp 0 t gnus-button-url 0) | 4158 | ("^[^:]+:" ,gnus-button-url-regexp 0 t browse-url 0) |
| 2805 | ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t | 4159 | ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t |
| 2806 | gnus-button-message-id 3)) | 4160 | gnus-button-message-id 3)) |
| 2807 | "*Alist of headers and regexps to match buttons in article heads. | 4161 | "*Alist of headers and regexps to match buttons in article heads. |
| @@ -2856,40 +4210,6 @@ call it with the value of the `gnus-data' text property." | |||
| 2856 | (when fun | 4210 | (when fun |
| 2857 | (funcall fun data)))) | 4211 | (funcall fun data)))) |
| 2858 | 4212 | ||
| 2859 | (defun gnus-article-prev-button (n) | ||
| 2860 | "Move point to N buttons backward. | ||
| 2861 | If N is negative, move forward instead." | ||
| 2862 | (interactive "p") | ||
| 2863 | (gnus-article-next-button (- n))) | ||
| 2864 | |||
| 2865 | (defun gnus-article-next-button (n) | ||
| 2866 | "Move point to N buttons forward. | ||
| 2867 | If N is negative, move backward instead." | ||
| 2868 | (interactive "p") | ||
| 2869 | (let ((function (if (< n 0) 'previous-single-property-change | ||
| 2870 | 'next-single-property-change)) | ||
| 2871 | (inhibit-point-motion-hooks t) | ||
| 2872 | (backward (< n 0)) | ||
| 2873 | (limit (if (< n 0) (point-min) (point-max)))) | ||
| 2874 | (setq n (abs n)) | ||
| 2875 | (while (and (not (= limit (point))) | ||
| 2876 | (> n 0)) | ||
| 2877 | ;; Skip past the current button. | ||
| 2878 | (when (get-text-property (point) 'gnus-callback) | ||
| 2879 | (goto-char (funcall function (point) 'gnus-callback nil limit))) | ||
| 2880 | ;; Go to the next (or previous) button. | ||
| 2881 | (gnus-goto-char (funcall function (point) 'gnus-callback nil limit)) | ||
| 2882 | ;; Put point at the start of the button. | ||
| 2883 | (when (and backward (not (get-text-property (point) 'gnus-callback))) | ||
| 2884 | (goto-char (funcall function (point) 'gnus-callback nil limit))) | ||
| 2885 | ;; Skip past intangible buttons. | ||
| 2886 | (when (get-text-property (point) 'intangible) | ||
| 2887 | (incf n)) | ||
| 2888 | (decf n)) | ||
| 2889 | (unless (zerop n) | ||
| 2890 | (gnus-message 5 "No more buttons")) | ||
| 2891 | n)) | ||
| 2892 | |||
| 2893 | (defun gnus-article-highlight (&optional force) | 4213 | (defun gnus-article-highlight (&optional force) |
| 2894 | "Highlight current article. | 4214 | "Highlight current article. |
| 2895 | This function calls `gnus-article-highlight-headers', | 4215 | This function calls `gnus-article-highlight-headers', |
| @@ -2924,7 +4244,7 @@ do the highlighting. See the documentation for those functions." | |||
| 2924 | (case-fold-search t) | 4244 | (case-fold-search t) |
| 2925 | (inhibit-point-motion-hooks t) | 4245 | (inhibit-point-motion-hooks t) |
| 2926 | entry regexp header-face field-face from hpoints fpoints) | 4246 | entry regexp header-face field-face from hpoints fpoints) |
| 2927 | (message-narrow-to-head) | 4247 | (article-narrow-to-head) |
| 2928 | (while (setq entry (pop alist)) | 4248 | (while (setq entry (pop alist)) |
| 2929 | (goto-char (point-min)) | 4249 | (goto-char (point-min)) |
| 2930 | (setq regexp (concat "^\\(" | 4250 | (setq regexp (concat "^\\(" |
| @@ -2990,18 +4310,19 @@ specified by `gnus-button-alist'." | |||
| 2990 | (alist gnus-button-alist) | 4310 | (alist gnus-button-alist) |
| 2991 | beg entry regexp) | 4311 | beg entry regexp) |
| 2992 | ;; Remove all old markers. | 4312 | ;; Remove all old markers. |
| 2993 | (let (marker entry) | 4313 | (let (marker entry new-list) |
| 2994 | (while (setq marker (pop gnus-button-marker-list)) | 4314 | (while (setq marker (pop gnus-button-marker-list)) |
| 2995 | (goto-char marker) | 4315 | (if (or (< marker (point-min)) (>= marker (point-max))) |
| 2996 | (when (setq entry (gnus-button-entry)) | 4316 | (push marker new-list) |
| 2997 | (put-text-property (match-beginning (nth 1 entry)) | 4317 | (goto-char marker) |
| 2998 | (match-end (nth 1 entry)) | 4318 | (when (setq entry (gnus-button-entry)) |
| 2999 | 'gnus-callback nil)) | 4319 | (put-text-property (match-beginning (nth 1 entry)) |
| 3000 | (set-marker marker nil))) | 4320 | (match-end (nth 1 entry)) |
| 4321 | 'gnus-callback nil)) | ||
| 4322 | (set-marker marker nil))) | ||
| 4323 | (setq gnus-button-marker-list new-list)) | ||
| 3001 | ;; We skip the headers. | 4324 | ;; We skip the headers. |
| 3002 | (goto-char (point-min)) | 4325 | (article-goto-body) |
| 3003 | (unless (search-forward "\n\n" nil t) | ||
| 3004 | (goto-char (point-max))) | ||
| 3005 | (setq beg (point)) | 4326 | (setq beg (point)) |
| 3006 | (while (setq entry (pop alist)) | 4327 | (while (setq entry (pop alist)) |
| 3007 | (setq regexp (car entry)) | 4328 | (setq regexp (car entry)) |
| @@ -3027,38 +4348,38 @@ specified by `gnus-button-alist'." | |||
| 3027 | (interactive) | 4348 | (interactive) |
| 3028 | (save-excursion | 4349 | (save-excursion |
| 3029 | (set-buffer gnus-article-buffer) | 4350 | (set-buffer gnus-article-buffer) |
| 3030 | (let ((buffer-read-only nil) | 4351 | (save-restriction |
| 3031 | (inhibit-point-motion-hooks t) | 4352 | (let ((buffer-read-only nil) |
| 3032 | (case-fold-search t) | 4353 | (inhibit-point-motion-hooks t) |
| 3033 | (alist gnus-header-button-alist) | 4354 | (case-fold-search t) |
| 3034 | entry beg end) | 4355 | (alist gnus-header-button-alist) |
| 3035 | (nnheader-narrow-to-headers) | 4356 | entry beg end) |
| 3036 | (while alist | 4357 | (article-narrow-to-head) |
| 3037 | ;; Each alist entry. | 4358 | (while alist |
| 3038 | (setq entry (car alist) | 4359 | ;; Each alist entry. |
| 3039 | alist (cdr alist)) | 4360 | (setq entry (car alist) |
| 3040 | (goto-char (point-min)) | 4361 | alist (cdr alist)) |
| 3041 | (while (re-search-forward (car entry) nil t) | 4362 | (goto-char (point-min)) |
| 3042 | ;; Each header matching the entry. | 4363 | (while (re-search-forward (car entry) nil t) |
| 3043 | (setq beg (match-beginning 0)) | 4364 | ;; Each header matching the entry. |
| 3044 | (setq end (or (and (re-search-forward "^[^ \t]" nil t) | 4365 | (setq beg (match-beginning 0)) |
| 3045 | (match-beginning 0)) | 4366 | (setq end (or (and (re-search-forward "^[^ \t]" nil t) |
| 3046 | (point-max))) | 4367 | (match-beginning 0)) |
| 3047 | (goto-char beg) | 4368 | (point-max))) |
| 3048 | (while (re-search-forward (nth 1 entry) end t) | 4369 | (goto-char beg) |
| 3049 | ;; Each match within a header. | 4370 | (while (re-search-forward (nth 1 entry) end t) |
| 3050 | (let* ((entry (cdr entry)) | 4371 | ;; Each match within a header. |
| 3051 | (start (match-beginning (nth 1 entry))) | 4372 | (let* ((entry (cdr entry)) |
| 3052 | (end (match-end (nth 1 entry))) | 4373 | (start (match-beginning (nth 1 entry))) |
| 3053 | (form (nth 2 entry))) | 4374 | (end (match-end (nth 1 entry))) |
| 3054 | (goto-char (match-end 0)) | 4375 | (form (nth 2 entry))) |
| 3055 | (when (eval form) | 4376 | (goto-char (match-end 0)) |
| 3056 | (gnus-article-add-button | 4377 | (when (eval form) |
| 3057 | start end (nth 3 entry) | 4378 | (gnus-article-add-button |
| 3058 | (buffer-substring (match-beginning (nth 4 entry)) | 4379 | start end (nth 3 entry) |
| 3059 | (match-end (nth 4 entry))))))) | 4380 | (buffer-substring (match-beginning (nth 4 entry)) |
| 3060 | (goto-char end)))) | 4381 | (match-end (nth 4 entry))))))) |
| 3061 | (widen))) | 4382 | (goto-char end))))))) |
| 3062 | 4383 | ||
| 3063 | ;;; External functions: | 4384 | ;;; External functions: |
| 3064 | 4385 | ||
| @@ -3072,7 +4393,9 @@ specified by `gnus-button-alist'." | |||
| 3072 | (nconc (and gnus-article-mouse-face | 4393 | (nconc (and gnus-article-mouse-face |
| 3073 | (list gnus-mouse-face-prop gnus-article-mouse-face)) | 4394 | (list gnus-mouse-face-prop gnus-article-mouse-face)) |
| 3074 | (list 'gnus-callback fun) | 4395 | (list 'gnus-callback fun) |
| 3075 | (and data (list 'gnus-data data))))) | 4396 | (and data (list 'gnus-data data)))) |
| 4397 | (widget-convert-button 'link from to :action 'gnus-widget-press-button | ||
| 4398 | :button-keymap gnus-widget-button-keymap)) | ||
| 3076 | 4399 | ||
| 3077 | ;;; Internal functions: | 4400 | ;;; Internal functions: |
| 3078 | 4401 | ||
| @@ -3104,7 +4427,6 @@ specified by `gnus-button-alist'." | |||
| 3104 | (defun gnus-button-push (marker) | 4427 | (defun gnus-button-push (marker) |
| 3105 | ;; Push button starting at MARKER. | 4428 | ;; Push button starting at MARKER. |
| 3106 | (save-excursion | 4429 | (save-excursion |
| 3107 | (set-buffer gnus-article-buffer) | ||
| 3108 | (goto-char marker) | 4430 | (goto-char marker) |
| 3109 | (let* ((entry (gnus-button-entry)) | 4431 | (let* ((entry (gnus-button-entry)) |
| 3110 | (inhibit-point-motion-hooks t) | 4432 | (inhibit-point-motion-hooks t) |
| @@ -3149,7 +4471,7 @@ specified by `gnus-button-alist'." | |||
| 3149 | 4471 | ||
| 3150 | (defun gnus-url-parse-query-string (query &optional downcase) | 4472 | (defun gnus-url-parse-query-string (query &optional downcase) |
| 3151 | (let (retval pairs cur key val) | 4473 | (let (retval pairs cur key val) |
| 3152 | (setq pairs (gnus-split-string query "&")) | 4474 | (setq pairs (split-string query "&")) |
| 3153 | (while pairs | 4475 | (while pairs |
| 3154 | (setq cur (car pairs) | 4476 | (setq cur (car pairs) |
| 3155 | pairs (cdr pairs)) | 4477 | pairs (cdr pairs)) |
| @@ -3230,13 +4552,8 @@ forbidden in URL encoding." | |||
| 3230 | ;; Reply to ADDRESS. | 4552 | ;; Reply to ADDRESS. |
| 3231 | (message-reply address)) | 4553 | (message-reply address)) |
| 3232 | 4554 | ||
| 3233 | (defun gnus-button-url (address) | ||
| 3234 | "Browse ADDRESS." | ||
| 3235 | (browse-url address)) | ||
| 3236 | |||
| 3237 | (defun gnus-button-embedded-url (address) | 4555 | (defun gnus-button-embedded-url (address) |
| 3238 | "Browse ADDRESS." | 4556 | "Browse ADDRESS." |
| 3239 | ;; In Emacs 20, `browse-url-browser-function' may be an alist. | ||
| 3240 | (browse-url (gnus-strip-whitespace address))) | 4557 | (browse-url (gnus-strip-whitespace address))) |
| 3241 | 4558 | ||
| 3242 | ;;; Next/prev buttons in the article buffer. | 4559 | ;;; Next/prev buttons in the article buffer. |
| @@ -3256,7 +4573,7 @@ forbidden in URL encoding." | |||
| 3256 | gnus-prev-page-line-format nil | 4573 | gnus-prev-page-line-format nil |
| 3257 | `(gnus-prev t local-map ,gnus-prev-page-map | 4574 | `(gnus-prev t local-map ,gnus-prev-page-map |
| 3258 | gnus-callback gnus-article-button-prev-page | 4575 | gnus-callback gnus-article-button-prev-page |
| 3259 | gnus-type annotation)))) | 4576 | article-type annotation)))) |
| 3260 | 4577 | ||
| 3261 | (defvar gnus-next-page-map nil) | 4578 | (defvar gnus-next-page-map nil) |
| 3262 | (unless gnus-next-page-map | 4579 | (unless gnus-next-page-map |
| @@ -3287,7 +4604,7 @@ forbidden in URL encoding." | |||
| 3287 | `(gnus-next | 4604 | `(gnus-next |
| 3288 | t local-map ,gnus-next-page-map | 4605 | t local-map ,gnus-next-page-map |
| 3289 | gnus-callback gnus-article-button-next-page | 4606 | gnus-callback gnus-article-button-next-page |
| 3290 | gnus-type annotation)))) | 4607 | article-type annotation)))) |
| 3291 | 4608 | ||
| 3292 | (defun gnus-article-button-next-page (arg) | 4609 | (defun gnus-article-button-next-page (arg) |
| 3293 | "Go to the next page." | 4610 | "Go to the next page." |
| @@ -3305,6 +4622,117 @@ forbidden in URL encoding." | |||
| 3305 | (gnus-article-prev-page) | 4622 | (gnus-article-prev-page) |
| 3306 | (select-window win))) | 4623 | (select-window win))) |
| 3307 | 4624 | ||
| 4625 | (defvar gnus-decode-header-methods | ||
| 4626 | '(mail-decode-encoded-word-region) | ||
| 4627 | "List of methods used to decode headers. | ||
| 4628 | |||
| 4629 | This variable is a list of FUNCTION or (REGEXP . FUNCTION). If item | ||
| 4630 | is FUNCTION, FUNCTION will be apply to all newsgroups. If item is a | ||
| 4631 | (REGEXP . FUNCTION), FUNCTION will be only apply to thes newsgroups | ||
| 4632 | whose names match REGEXP. | ||
| 4633 | |||
| 4634 | For example: | ||
| 4635 | ((\"chinese\" . gnus-decode-encoded-word-region-by-guess) | ||
| 4636 | mail-decode-encoded-word-region | ||
| 4637 | (\"chinese\" . rfc1843-decode-region)) | ||
| 4638 | ") | ||
| 4639 | |||
| 4640 | (defvar gnus-decode-header-methods-cache nil) | ||
| 4641 | |||
| 4642 | (defun gnus-multi-decode-header (start end) | ||
| 4643 | "Apply the functions from `gnus-encoded-word-methods' that match." | ||
| 4644 | (unless (and gnus-decode-header-methods-cache | ||
| 4645 | (eq gnus-newsgroup-name | ||
| 4646 | (car gnus-decode-header-methods-cache))) | ||
| 4647 | (setq gnus-decode-header-methods-cache (list gnus-newsgroup-name)) | ||
| 4648 | (mapcar (lambda (x) | ||
| 4649 | (if (symbolp x) | ||
| 4650 | (nconc gnus-decode-header-methods-cache (list x)) | ||
| 4651 | (if (and gnus-newsgroup-name | ||
| 4652 | (string-match (car x) gnus-newsgroup-name)) | ||
| 4653 | (nconc gnus-decode-header-methods-cache | ||
| 4654 | (list (cdr x)))))) | ||
| 4655 | gnus-decode-header-methods)) | ||
| 4656 | (let ((xlist gnus-decode-header-methods-cache)) | ||
| 4657 | (pop xlist) | ||
| 4658 | (save-restriction | ||
| 4659 | (narrow-to-region start end) | ||
| 4660 | (while xlist | ||
| 4661 | (funcall (pop xlist) (point-min) (point-max)))))) | ||
| 4662 | |||
| 4663 | ;;; | ||
| 4664 | ;;; Treatment top-level handling. | ||
| 4665 | ;;; | ||
| 4666 | |||
| 4667 | (defun gnus-treat-article (condition &optional part-number total-parts type) | ||
| 4668 | (let ((length (- (point-max) (point-min))) | ||
| 4669 | (alist gnus-treatment-function-alist) | ||
| 4670 | (article-goto-body-goes-to-point-min-p t) | ||
| 4671 | (treated-type | ||
| 4672 | (or (not type) | ||
| 4673 | (catch 'found | ||
| 4674 | (let ((list gnus-article-treat-types)) | ||
| 4675 | (while list | ||
| 4676 | (when (string-match (pop list) type) | ||
| 4677 | (throw 'found t))))))) | ||
| 4678 | (highlightp (gnus-visual-p 'article-highlight 'highlight)) | ||
| 4679 | val elem) | ||
| 4680 | (gnus-run-hooks 'gnus-part-display-hook) | ||
| 4681 | (while (setq elem (pop alist)) | ||
| 4682 | (setq val | ||
| 4683 | (save-excursion | ||
| 4684 | (if (gnus-buffer-live-p gnus-summary-buffer) | ||
| 4685 | (set-buffer gnus-summary-buffer)) | ||
| 4686 | (symbol-value (car elem)))) | ||
| 4687 | (when (and (or (consp val) | ||
| 4688 | treated-type) | ||
| 4689 | (gnus-treat-predicate val) | ||
| 4690 | (or (not (get (car elem) 'highlight)) | ||
| 4691 | highlightp)) | ||
| 4692 | (save-restriction | ||
| 4693 | (funcall (cadr elem))))))) | ||
| 4694 | |||
| 4695 | ;; Dynamic variables. | ||
| 4696 | (defvar part-number) | ||
| 4697 | (defvar total-parts) | ||
| 4698 | (defvar type) | ||
| 4699 | (defvar condition) | ||
| 4700 | (defvar length) | ||
| 4701 | (defun gnus-treat-predicate (val) | ||
| 4702 | (cond | ||
| 4703 | ((null val) | ||
| 4704 | nil) | ||
| 4705 | ((and (listp val) | ||
| 4706 | (stringp (car val))) | ||
| 4707 | (apply 'gnus-or (mapcar `(lambda (s) | ||
| 4708 | (string-match s ,(or gnus-newsgroup-name ""))) | ||
| 4709 | val))) | ||
| 4710 | ((listp val) | ||
| 4711 | (let ((pred (pop val))) | ||
| 4712 | (cond | ||
| 4713 | ((eq pred 'or) | ||
| 4714 | (apply 'gnus-or (mapcar 'gnus-treat-predicate val))) | ||
| 4715 | ((eq pred 'and) | ||
| 4716 | (apply 'gnus-and (mapcar 'gnus-treat-predicate val))) | ||
| 4717 | ((eq pred 'not) | ||
| 4718 | (not (gnus-treat-predicate (car val)))) | ||
| 4719 | ((eq pred 'typep) | ||
| 4720 | (equal (car val) type)) | ||
| 4721 | (t | ||
| 4722 | (error "%S is not a valid predicate" pred))))) | ||
| 4723 | (condition | ||
| 4724 | (eq condition val)) | ||
| 4725 | ((eq val t) | ||
| 4726 | t) | ||
| 4727 | ((eq val 'head) | ||
| 4728 | nil) | ||
| 4729 | ((eq val 'last) | ||
| 4730 | (eq part-number total-parts)) | ||
| 4731 | ((numberp val) | ||
| 4732 | (< length val)) | ||
| 4733 | (t | ||
| 4734 | (error "%S is not a valid value" val)))) | ||
| 4735 | |||
| 3308 | (gnus-ems-redefine) | 4736 | (gnus-ems-redefine) |
| 3309 | 4737 | ||
| 3310 | (provide 'gnus-art) | 4738 | (provide 'gnus-art) |
diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index c881f5976d9..0aead88df25 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el | |||
| @@ -1,5 +1,6 @@ | |||
| 1 | ;;; gnus-group.el --- group mode commands for Gnus | 1 | ;;; gnus-group.el --- group mode commands for Gnus |
| 2 | ;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. | 2 | ;; Copyright (C) 1996, 1997, 1998, 1999, 2000 |
| 3 | ;; Free Software Foundation, Inc. | ||
| 3 | 4 | ||
| 4 | ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> | 5 | ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
| 5 | ;; Keywords: news | 6 | ;; Keywords: news |
| @@ -27,8 +28,6 @@ | |||
| 27 | 28 | ||
| 28 | (eval-when-compile (require 'cl)) | 29 | (eval-when-compile (require 'cl)) |
| 29 | 30 | ||
| 30 | (eval-when-compile (require 'cl)) | ||
| 31 | |||
| 32 | (require 'gnus) | 31 | (require 'gnus) |
| 33 | (require 'gnus-start) | 32 | (require 'gnus-start) |
| 34 | (require 'nnmail) | 33 | (require 'nnmail) |
| @@ -37,6 +36,7 @@ | |||
| 37 | (require 'gnus-range) | 36 | (require 'gnus-range) |
| 38 | (require 'gnus-win) | 37 | (require 'gnus-win) |
| 39 | (require 'gnus-undo) | 38 | (require 'gnus-undo) |
| 39 | (require 'time-date) | ||
| 40 | 40 | ||
| 41 | (defcustom gnus-group-archive-directory | 41 | (defcustom gnus-group-archive-directory |
| 42 | "*ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list/" | 42 | "*ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list/" |
| @@ -50,7 +50,7 @@ | |||
| 50 | :group 'gnus-group-foreign | 50 | :group 'gnus-group-foreign |
| 51 | :type 'directory) | 51 | :type 'directory) |
| 52 | 52 | ||
| 53 | (defcustom gnus-no-groups-message "No news is no news" | 53 | (defcustom gnus-no-groups-message "No gnus is bad news" |
| 54 | "*Message displayed by Gnus when no groups are available." | 54 | "*Message displayed by Gnus when no groups are available." |
| 55 | :group 'gnus-start | 55 | :group 'gnus-start |
| 56 | :type 'string) | 56 | :type 'string) |
| @@ -162,6 +162,7 @@ with some simple extensions. | |||
| 162 | %n Select from where (string) | 162 | %n Select from where (string) |
| 163 | %z A string that look like `<%s:%n>' if a foreign select method is used | 163 | %z A string that look like `<%s:%n>' if a foreign select method is used |
| 164 | %d The date the group was last entered. | 164 | %d The date the group was last entered. |
| 165 | %E Icon as defined by `gnus-group-icon-list'. | ||
| 165 | %u User defined specifier. The next character in the format string should | 166 | %u User defined specifier. The next character in the format string should |
| 166 | be a letter. Gnus will call the function gnus-user-format-function-X, | 167 | be a letter. Gnus will call the function gnus-user-format-function-X, |
| 167 | where X is the letter following %u. The function will be passed the | 168 | where X is the letter following %u. The function will be passed the |
| @@ -300,6 +301,18 @@ variable." | |||
| 300 | gnus-group-news-3-empty-face) | 301 | gnus-group-news-3-empty-face) |
| 301 | ((and (not mailp) (eq level 3)) . | 302 | ((and (not mailp) (eq level 3)) . |
| 302 | gnus-group-news-3-face) | 303 | gnus-group-news-3-face) |
| 304 | ((and (= unread 0) (not mailp) (eq level 4)) . | ||
| 305 | gnus-group-news-4-empty-face) | ||
| 306 | ((and (not mailp) (eq level 4)) . | ||
| 307 | gnus-group-news-4-face) | ||
| 308 | ((and (= unread 0) (not mailp) (eq level 5)) . | ||
| 309 | gnus-group-news-5-empty-face) | ||
| 310 | ((and (not mailp) (eq level 5)) . | ||
| 311 | gnus-group-news-5-face) | ||
| 312 | ((and (= unread 0) (not mailp) (eq level 6)) . | ||
| 313 | gnus-group-news-6-empty-face) | ||
| 314 | ((and (not mailp) (eq level 6)) . | ||
| 315 | gnus-group-news-6-face) | ||
| 303 | ((and (= unread 0) (not mailp)) . | 316 | ((and (= unread 0) (not mailp)) . |
| 304 | gnus-group-news-low-empty-face) | 317 | gnus-group-news-low-empty-face) |
| 305 | ((and (not mailp)) . | 318 | ((and (not mailp)) . |
| @@ -320,7 +333,7 @@ variable." | |||
| 320 | ((= unread 0) . | 333 | ((= unread 0) . |
| 321 | gnus-group-mail-low-empty-face) | 334 | gnus-group-mail-low-empty-face) |
| 322 | (t . | 335 | (t . |
| 323 | gnus-group-mail-low-face)) | 336 | gnus-group-mail-low-face)) |
| 324 | "*Controls the highlighting of group buffer lines. | 337 | "*Controls the highlighting of group buffer lines. |
| 325 | 338 | ||
| 326 | Below is a list of `Form'/`Face' pairs. When deciding how a a | 339 | Below is a list of `Form'/`Face' pairs. When deciding how a a |
| @@ -349,6 +362,56 @@ ticked: The number of ticked articles." | |||
| 349 | :group 'gnus-group-visual | 362 | :group 'gnus-group-visual |
| 350 | :type 'character) | 363 | :type 'character) |
| 351 | 364 | ||
| 365 | (defgroup gnus-group-icons nil | ||
| 366 | "Add Icons to your group buffer. " | ||
| 367 | :group 'gnus-group-visual) | ||
| 368 | |||
| 369 | (defcustom gnus-group-icon-list | ||
| 370 | nil | ||
| 371 | "*Controls the insertion of icons into group buffer lines. | ||
| 372 | |||
| 373 | Below is a list of `Form'/`File' pairs. When deciding how a | ||
| 374 | particular group line should be displayed, each form is evaluated. | ||
| 375 | The icon from the file field after the first true form is used. You | ||
| 376 | can change how those group lines are displayed by editing the file | ||
| 377 | field. The File will either be found in the | ||
| 378 | `gnus-group-glyph-directory' or by designating absolute path to the | ||
| 379 | file. | ||
| 380 | |||
| 381 | It is also possible to change and add form fields, but currently that | ||
| 382 | requires an understanding of Lisp expressions. Hopefully this will | ||
| 383 | change in a future release. For now, you can use the following | ||
| 384 | variables in the Lisp expression: | ||
| 385 | |||
| 386 | group: The name of the group. | ||
| 387 | unread: The number of unread articles in the group. | ||
| 388 | method: The select method used. | ||
| 389 | mailp: Whether it's a mail group or not. | ||
| 390 | newsp: Whether it's a news group or not | ||
| 391 | level: The level of the group. | ||
| 392 | score: The score of the group. | ||
| 393 | ticked: The number of ticked articles." | ||
| 394 | :group 'gnus-group-icons | ||
| 395 | :type '(repeat (cons (sexp :tag "Form") file))) | ||
| 396 | |||
| 397 | (defcustom gnus-group-name-charset-method-alist nil | ||
| 398 | "*Alist of method and the charset for group names. | ||
| 399 | |||
| 400 | For example: | ||
| 401 | (((nntp \"news.com.cn\") . cn-gb-2312)) | ||
| 402 | " | ||
| 403 | :group 'gnus-charset | ||
| 404 | :type '(repeat (cons (sexp :tag "Method") (symbol :tag "Charset")))) | ||
| 405 | |||
| 406 | (defcustom gnus-group-name-charset-group-alist nil | ||
| 407 | "*Alist of group regexp and the charset for group names. | ||
| 408 | |||
| 409 | For example: | ||
| 410 | ((\"\\.com\\.cn:\" . cn-gb-2312)) | ||
| 411 | " | ||
| 412 | :group 'gnus-charset | ||
| 413 | :type '(repeat (cons (regexp :tag "Group") (symbol :tag "Charset")))) | ||
| 414 | |||
| 352 | ;;; Internal variables | 415 | ;;; Internal variables |
| 353 | 416 | ||
| 354 | (defvar gnus-group-sort-alist-function 'gnus-group-sort-flat | 417 | (defvar gnus-group-sort-alist-function 'gnus-group-sort-flat |
| @@ -393,6 +456,7 @@ ticked: The number of ticked articles." | |||
| 393 | (?s gnus-tmp-news-server ?s) | 456 | (?s gnus-tmp-news-server ?s) |
| 394 | (?n gnus-tmp-news-method ?s) | 457 | (?n gnus-tmp-news-method ?s) |
| 395 | (?P gnus-group-indentation ?s) | 458 | (?P gnus-group-indentation ?s) |
| 459 | (?E gnus-tmp-group-icon ?s) | ||
| 396 | (?l gnus-tmp-grouplens ?s) | 460 | (?l gnus-tmp-grouplens ?s) |
| 397 | (?z gnus-tmp-news-method-string ?s) | 461 | (?z gnus-tmp-news-method-string ?s) |
| 398 | (?m (gnus-group-new-mail gnus-tmp-group) ?c) | 462 | (?m (gnus-group-new-mail gnus-tmp-group) ?c) |
| @@ -415,6 +479,9 @@ ticked: The number of ticked articles." | |||
| 415 | 479 | ||
| 416 | (defvar gnus-group-list-mode nil) | 480 | (defvar gnus-group-list-mode nil) |
| 417 | 481 | ||
| 482 | |||
| 483 | (defvar gnus-group-icon-cache nil) | ||
| 484 | |||
| 418 | ;;; | 485 | ;;; |
| 419 | ;;; Gnus group mode | 486 | ;;; Gnus group mode |
| 420 | ;;; | 487 | ;;; |
| @@ -427,6 +494,7 @@ ticked: The number of ticked articles." | |||
| 427 | "=" gnus-group-select-group | 494 | "=" gnus-group-select-group |
| 428 | "\r" gnus-group-select-group | 495 | "\r" gnus-group-select-group |
| 429 | "\M-\r" gnus-group-quick-select-group | 496 | "\M-\r" gnus-group-quick-select-group |
| 497 | "\M- " gnus-group-visible-select-group | ||
| 430 | [(meta control return)] gnus-group-select-group-ephemerally | 498 | [(meta control return)] gnus-group-select-group-ephemerally |
| 431 | "j" gnus-group-jump-to-group | 499 | "j" gnus-group-jump-to-group |
| 432 | "n" gnus-group-next-unread-group | 500 | "n" gnus-group-next-unread-group |
| @@ -503,6 +571,7 @@ ticked: The number of ticked articles." | |||
| 503 | "u" gnus-group-make-useful-group | 571 | "u" gnus-group-make-useful-group |
| 504 | "a" gnus-group-make-archive-group | 572 | "a" gnus-group-make-archive-group |
| 505 | "k" gnus-group-make-kiboze-group | 573 | "k" gnus-group-make-kiboze-group |
| 574 | "l" gnus-group-nnimap-edit-acl | ||
| 506 | "m" gnus-group-make-group | 575 | "m" gnus-group-make-group |
| 507 | "E" gnus-group-edit-group | 576 | "E" gnus-group-edit-group |
| 508 | "e" gnus-group-edit-group-method | 577 | "e" gnus-group-edit-group-method |
| @@ -514,6 +583,7 @@ ticked: The number of ticked articles." | |||
| 514 | "w" gnus-group-make-web-group | 583 | "w" gnus-group-make-web-group |
| 515 | "r" gnus-group-rename-group | 584 | "r" gnus-group-rename-group |
| 516 | "c" gnus-group-customize | 585 | "c" gnus-group-customize |
| 586 | "x" gnus-group-nnimap-expunge | ||
| 517 | "\177" gnus-group-delete-group | 587 | "\177" gnus-group-delete-group |
| 518 | [delete] gnus-group-delete-group) | 588 | [delete] gnus-group-delete-group) |
| 519 | 589 | ||
| @@ -552,7 +622,9 @@ ticked: The number of ticked articles." | |||
| 552 | "d" gnus-group-description-apropos | 622 | "d" gnus-group-description-apropos |
| 553 | "m" gnus-group-list-matching | 623 | "m" gnus-group-list-matching |
| 554 | "M" gnus-group-list-all-matching | 624 | "M" gnus-group-list-all-matching |
| 555 | "l" gnus-group-list-level) | 625 | "l" gnus-group-list-level |
| 626 | "c" gnus-group-list-cached | ||
| 627 | "?" gnus-group-list-dormant) | ||
| 556 | 628 | ||
| 557 | (gnus-define-keys (gnus-group-score-map "W" gnus-group-mode-map) | 629 | (gnus-define-keys (gnus-group-score-map "W" gnus-group-mode-map) |
| 558 | "f" gnus-score-flush-cache) | 630 | "f" gnus-score-flush-cache) |
| @@ -628,7 +700,9 @@ ticked: The number of ticked articles." | |||
| 628 | ["Group and description apropos..." gnus-group-description-apropos t] | 700 | ["Group and description apropos..." gnus-group-description-apropos t] |
| 629 | ["List groups matching..." gnus-group-list-matching t] | 701 | ["List groups matching..." gnus-group-list-matching t] |
| 630 | ["List all groups matching..." gnus-group-list-all-matching t] | 702 | ["List all groups matching..." gnus-group-list-all-matching t] |
| 631 | ["List active file" gnus-group-list-active t]) | 703 | ["List active file" gnus-group-list-active t] |
| 704 | ["List groups with cached" gnus-group-list-cached t] | ||
| 705 | ["List groups with dormant" gnus-group-list-dormant t]) | ||
| 632 | ("Sort" | 706 | ("Sort" |
| 633 | ["Default sort" gnus-group-sort-groups t] | 707 | ["Default sort" gnus-group-sort-groups t] |
| 634 | ["Sort by method" gnus-group-sort-groups-by-method t] | 708 | ["Sort by method" gnus-group-sort-groups-by-method t] |
| @@ -714,7 +788,6 @@ ticked: The number of ticked articles." | |||
| 714 | ["Pack packet" gnus-soup-pack-packet (fboundp 'gnus-soup-pack-packet)] | 788 | ["Pack packet" gnus-soup-pack-packet (fboundp 'gnus-soup-pack-packet)] |
| 715 | ["Save areas" gnus-soup-save-areas (fboundp 'gnus-soup-pack-packet)] | 789 | ["Save areas" gnus-soup-save-areas (fboundp 'gnus-soup-pack-packet)] |
| 716 | ["Brew SOUP" gnus-group-brew-soup (fboundp 'gnus-soup-pack-packet)]) | 790 | ["Brew SOUP" gnus-group-brew-soup (fboundp 'gnus-soup-pack-packet)]) |
| 717 | ["Send a bug report" gnus-bug t] | ||
| 718 | ["Send a mail" gnus-group-mail t] | 791 | ["Send a mail" gnus-group-mail t] |
| 719 | ["Post an article..." gnus-group-post-news t] | 792 | ["Post an article..." gnus-group-post-news t] |
| 720 | ["Check for new news" gnus-group-get-new-news t] | 793 | ["Check for new news" gnus-group-get-new-news t] |
| @@ -765,14 +838,12 @@ The following commands are available: | |||
| 765 | (gnus-group-set-mode-line) | 838 | (gnus-group-set-mode-line) |
| 766 | (setq mode-line-process nil) | 839 | (setq mode-line-process nil) |
| 767 | (use-local-map gnus-group-mode-map) | 840 | (use-local-map gnus-group-mode-map) |
| 768 | (buffer-disable-undo (current-buffer)) | 841 | (buffer-disable-undo) |
| 769 | (setq truncate-lines t) | 842 | (setq truncate-lines t) |
| 770 | (setq buffer-read-only t) | 843 | (setq buffer-read-only t) |
| 771 | (gnus-set-default-directory) | 844 | (gnus-set-default-directory) |
| 772 | (gnus-update-format-specifications nil 'group 'group-mode) | 845 | (gnus-update-format-specifications nil 'group 'group-mode) |
| 773 | (gnus-update-group-mark-positions) | 846 | (gnus-update-group-mark-positions) |
| 774 | (make-local-hook 'post-command-hook) | ||
| 775 | (add-hook 'post-command-hook 'gnus-clear-inboxes-moved nil t) | ||
| 776 | (when gnus-use-undo | 847 | (when gnus-use-undo |
| 777 | (gnus-undo-mode 1)) | 848 | (gnus-undo-mode 1)) |
| 778 | (when gnus-slave | 849 | (when gnus-slave |
| @@ -793,9 +864,6 @@ The following commands are available: | |||
| 793 | (list (cons 'process (and (search-forward "\200" nil t) | 864 | (list (cons 'process (and (search-forward "\200" nil t) |
| 794 | (- (point) 2)))))))) | 865 | (- (point) 2)))))))) |
| 795 | 866 | ||
| 796 | (defun gnus-clear-inboxes-moved () | ||
| 797 | (setq nnmail-moved-inboxes nil)) | ||
| 798 | |||
| 799 | (defun gnus-mouse-pick-group (e) | 867 | (defun gnus-mouse-pick-group (e) |
| 800 | "Enter the group under the mouse pointer." | 868 | "Enter the group under the mouse pointer." |
| 801 | (interactive "e") | 869 | (interactive "e") |
| @@ -826,6 +894,29 @@ The following commands are available: | |||
| 826 | (when gnus-carpal | 894 | (when gnus-carpal |
| 827 | (gnus-carpal-setup-buffer 'group)))) | 895 | (gnus-carpal-setup-buffer 'group)))) |
| 828 | 896 | ||
| 897 | (defsubst gnus-group-name-charset (method group) | ||
| 898 | (if (null method) | ||
| 899 | (setq method (gnus-find-method-for-group group))) | ||
| 900 | (let ((item (assoc method gnus-group-name-charset-method-alist)) | ||
| 901 | (alist gnus-group-name-charset-group-alist) | ||
| 902 | result) | ||
| 903 | (if item | ||
| 904 | (cdr item) | ||
| 905 | (while (setq item (pop alist)) | ||
| 906 | (if (string-match (car item) group) | ||
| 907 | (setq alist nil | ||
| 908 | result (cdr item)))) | ||
| 909 | result))) | ||
| 910 | |||
| 911 | (defsubst gnus-group-name-decode (string charset) | ||
| 912 | (if (and string charset (featurep 'mule)) | ||
| 913 | (mm-decode-coding-string string charset) | ||
| 914 | string)) | ||
| 915 | |||
| 916 | (defun gnus-group-decoded-name (string) | ||
| 917 | (let ((charset (gnus-group-name-charset nil string))) | ||
| 918 | (gnus-group-name-decode string charset))) | ||
| 919 | |||
| 829 | (defun gnus-group-list-groups (&optional level unread lowest) | 920 | (defun gnus-group-list-groups (&optional level unread lowest) |
| 830 | "List newsgroups with level LEVEL or lower that have unread articles. | 921 | "List newsgroups with level LEVEL or lower that have unread articles. |
| 831 | Default is all subscribed groups. | 922 | Default is all subscribed groups. |
| @@ -840,8 +931,6 @@ Also see the `gnus-group-use-permanent-levels' variable." | |||
| 840 | (gnus-group-default-level nil t) | 931 | (gnus-group-default-level nil t) |
| 841 | gnus-group-default-list-level | 932 | gnus-group-default-list-level |
| 842 | gnus-level-subscribed)))) | 933 | gnus-level-subscribed)))) |
| 843 | ;; Just do this here, for no particular good reason. | ||
| 844 | (gnus-clear-inboxes-moved) | ||
| 845 | (unless level | 934 | (unless level |
| 846 | (setq level (car gnus-group-list-mode) | 935 | (setq level (car gnus-group-list-mode) |
| 847 | unread (cdr gnus-group-list-mode))) | 936 | unread (cdr gnus-group-list-mode))) |
| @@ -920,7 +1009,7 @@ If REGEXP, only list groups matching REGEXP." | |||
| 920 | params (gnus-info-params info) | 1009 | params (gnus-info-params info) |
| 921 | newsrc (cdr newsrc) | 1010 | newsrc (cdr newsrc) |
| 922 | unread (car (gnus-gethash group gnus-newsrc-hashtb))) | 1011 | unread (car (gnus-gethash group gnus-newsrc-hashtb))) |
| 923 | (and unread ; This group might be bogus | 1012 | (and unread ; This group might be unchecked |
| 924 | (or (not regexp) | 1013 | (or (not regexp) |
| 925 | (string-match regexp group)) | 1014 | (string-match regexp group)) |
| 926 | (<= (setq clevel (gnus-info-level info)) level) | 1015 | (<= (setq clevel (gnus-info-level info)) level) |
| @@ -971,16 +1060,24 @@ If REGEXP, only list groups matching REGEXP." | |||
| 971 | (when (string-match regexp group) | 1060 | (when (string-match regexp group) |
| 972 | (gnus-add-text-properties | 1061 | (gnus-add-text-properties |
| 973 | (point) (prog1 (1+ (point)) | 1062 | (point) (prog1 (1+ (point)) |
| 974 | (insert " " mark " *: " group "\n")) | 1063 | (insert " " mark " *: " |
| 1064 | (gnus-group-name-decode group | ||
| 1065 | (gnus-group-name-charset | ||
| 1066 | nil group)) | ||
| 1067 | "\n")) | ||
| 975 | (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb) | 1068 | (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb) |
| 976 | 'gnus-unread t | 1069 | 'gnus-unread t |
| 977 | 'gnus-level level)))) | 1070 | 'gnus-level level)))) |
| 978 | ;; This loop is used when listing all groups. | 1071 | ;; This loop is used when listing all groups. |
| 979 | (while groups | 1072 | (while groups |
| 1073 | (setq group (pop groups)) | ||
| 980 | (gnus-add-text-properties | 1074 | (gnus-add-text-properties |
| 981 | (point) (prog1 (1+ (point)) | 1075 | (point) (prog1 (1+ (point)) |
| 982 | (insert " " mark " *: " | 1076 | (insert " " mark " *: " |
| 983 | (setq group (pop groups)) "\n")) | 1077 | (gnus-group-name-decode group |
| 1078 | (gnus-group-name-charset | ||
| 1079 | nil group)) | ||
| 1080 | "\n")) | ||
| 984 | (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb) | 1081 | (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb) |
| 985 | 'gnus-unread t | 1082 | 'gnus-unread t |
| 986 | 'gnus-level level)))))) | 1083 | 'gnus-level level)))))) |
| @@ -1032,7 +1129,11 @@ If REGEXP, only list groups matching REGEXP." | |||
| 1032 | gnus-tmp-marked number | 1129 | gnus-tmp-marked number |
| 1033 | gnus-tmp-method) | 1130 | gnus-tmp-method) |
| 1034 | "Insert a group line in the group buffer." | 1131 | "Insert a group line in the group buffer." |
| 1035 | (let* ((gnus-tmp-active (gnus-active gnus-tmp-group)) | 1132 | (let* ((gnus-tmp-method |
| 1133 | (gnus-server-get-method gnus-tmp-group gnus-tmp-method)) | ||
| 1134 | (group-name-charset (gnus-group-name-charset gnus-tmp-method | ||
| 1135 | gnus-tmp-group)) | ||
| 1136 | (gnus-tmp-active (gnus-active gnus-tmp-group)) | ||
| 1036 | (gnus-tmp-number-total | 1137 | (gnus-tmp-number-total |
| 1037 | (if gnus-tmp-active | 1138 | (if gnus-tmp-active |
| 1038 | (1+ (- (cdr gnus-tmp-active) (car gnus-tmp-active))) | 1139 | (1+ (- (cdr gnus-tmp-active) (car gnus-tmp-active))) |
| @@ -1049,10 +1150,14 @@ If REGEXP, only list groups matching REGEXP." | |||
| 1049 | ((<= gnus-tmp-level gnus-level-unsubscribed) ?U) | 1150 | ((<= gnus-tmp-level gnus-level-unsubscribed) ?U) |
| 1050 | ((= gnus-tmp-level gnus-level-zombie) ?Z) | 1151 | ((= gnus-tmp-level gnus-level-zombie) ?Z) |
| 1051 | (t ?K))) | 1152 | (t ?K))) |
| 1052 | (gnus-tmp-qualified-group (gnus-group-real-name gnus-tmp-group)) | 1153 | (gnus-tmp-qualified-group |
| 1154 | (gnus-group-name-decode (gnus-group-real-name gnus-tmp-group) | ||
| 1155 | group-name-charset)) | ||
| 1053 | (gnus-tmp-newsgroup-description | 1156 | (gnus-tmp-newsgroup-description |
| 1054 | (if gnus-description-hashtb | 1157 | (if gnus-description-hashtb |
| 1055 | (or (gnus-gethash gnus-tmp-group gnus-description-hashtb) "") | 1158 | (or (gnus-group-name-decode |
| 1159 | (gnus-gethash gnus-tmp-group gnus-description-hashtb) | ||
| 1160 | group-name-charset) "") | ||
| 1056 | "")) | 1161 | "")) |
| 1057 | (gnus-tmp-moderated | 1162 | (gnus-tmp-moderated |
| 1058 | (if (and gnus-moderated-hashtb | 1163 | (if (and gnus-moderated-hashtb |
| @@ -1060,8 +1165,7 @@ If REGEXP, only list groups matching REGEXP." | |||
| 1060 | ?m ? )) | 1165 | ?m ? )) |
| 1061 | (gnus-tmp-moderated-string | 1166 | (gnus-tmp-moderated-string |
| 1062 | (if (eq gnus-tmp-moderated ?m) "(m)" "")) | 1167 | (if (eq gnus-tmp-moderated ?m) "(m)" "")) |
| 1063 | (gnus-tmp-method | 1168 | (gnus-tmp-group-icon "==&&==") |
| 1064 | (gnus-server-get-method gnus-tmp-group gnus-tmp-method)) ; | ||
| 1065 | (gnus-tmp-news-server (or (cadr gnus-tmp-method) "")) | 1169 | (gnus-tmp-news-server (or (cadr gnus-tmp-method) "")) |
| 1066 | (gnus-tmp-news-method (or (car gnus-tmp-method) "")) | 1170 | (gnus-tmp-news-method (or (car gnus-tmp-method) "")) |
| 1067 | (gnus-tmp-news-method-string | 1171 | (gnus-tmp-news-method-string |
| @@ -1095,10 +1199,10 @@ If REGEXP, only list groups matching REGEXP." | |||
| 1095 | gnus-marked ,gnus-tmp-marked-mark | 1199 | gnus-marked ,gnus-tmp-marked-mark |
| 1096 | gnus-indentation ,gnus-group-indentation | 1200 | gnus-indentation ,gnus-group-indentation |
| 1097 | gnus-level ,gnus-tmp-level)) | 1201 | gnus-level ,gnus-tmp-level)) |
| 1202 | (forward-line -1) | ||
| 1098 | (when (inline (gnus-visual-p 'group-highlight 'highlight)) | 1203 | (when (inline (gnus-visual-p 'group-highlight 'highlight)) |
| 1099 | (forward-line -1) | 1204 | (gnus-run-hooks 'gnus-group-update-hook)) |
| 1100 | (gnus-run-hooks 'gnus-group-update-hook) | 1205 | (forward-line) |
| 1101 | (forward-line)) | ||
| 1102 | ;; Allow XEmacs to remove front-sticky text properties. | 1206 | ;; Allow XEmacs to remove front-sticky text properties. |
| 1103 | (gnus-group-remove-excess-properties))) | 1207 | (gnus-group-remove-excess-properties))) |
| 1104 | 1208 | ||
| @@ -1317,6 +1421,12 @@ If FIRST-TOO, the current line is also eligible as a target." | |||
| 1317 | 1421 | ||
| 1318 | ;; Group marking. | 1422 | ;; Group marking. |
| 1319 | 1423 | ||
| 1424 | (defun gnus-group-mark-line-p () | ||
| 1425 | (save-excursion | ||
| 1426 | (beginning-of-line) | ||
| 1427 | (forward-char (or (cdr (assq 'process gnus-group-mark-positions)) 2)) | ||
| 1428 | (eq (char-after) gnus-process-mark))) | ||
| 1429 | |||
| 1320 | (defun gnus-group-mark-group (n &optional unmark no-advance) | 1430 | (defun gnus-group-mark-group (n &optional unmark no-advance) |
| 1321 | "Mark the current group." | 1431 | "Mark the current group." |
| 1322 | (interactive "p") | 1432 | (interactive "p") |
| @@ -1329,7 +1439,7 @@ If FIRST-TOO, the current line is also eligible as a target." | |||
| 1329 | (beginning-of-line) | 1439 | (beginning-of-line) |
| 1330 | (forward-char (or (cdr (assq 'process gnus-group-mark-positions)) 2)) | 1440 | (forward-char (or (cdr (assq 'process gnus-group-mark-positions)) 2)) |
| 1331 | (subst-char-in-region | 1441 | (subst-char-in-region |
| 1332 | (point) (1+ (point)) (following-char) | 1442 | (point) (1+ (point)) (char-after) |
| 1333 | (if unmark | 1443 | (if unmark |
| 1334 | (progn | 1444 | (progn |
| 1335 | (setq gnus-group-marked (delete group gnus-group-marked)) | 1445 | (setq gnus-group-marked (delete group gnus-group-marked)) |
| @@ -1383,10 +1493,10 @@ If UNMARK, remove the mark instead." | |||
| 1383 | (gnus-group-set-mark group)))) | 1493 | (gnus-group-set-mark group)))) |
| 1384 | (gnus-group-position-point)) | 1494 | (gnus-group-position-point)) |
| 1385 | 1495 | ||
| 1386 | (defun gnus-group-remove-mark (group) | 1496 | (defun gnus-group-remove-mark (group &optional test-marked) |
| 1387 | "Remove the process mark from GROUP and move point there. | 1497 | "Remove the process mark from GROUP and move point there. |
| 1388 | Return nil if the group isn't displayed." | 1498 | Return nil if the group isn't displayed." |
| 1389 | (if (gnus-group-goto-group group) | 1499 | (if (gnus-group-goto-group group nil test-marked) |
| 1390 | (save-excursion | 1500 | (save-excursion |
| 1391 | (gnus-group-mark-group 1 'unmark t) | 1501 | (gnus-group-mark-group 1 'unmark t) |
| 1392 | t) | 1502 | t) |
| @@ -1465,12 +1575,14 @@ Take into consideration N (the prefix) and the list of marked groups." | |||
| 1465 | (eval | 1575 | (eval |
| 1466 | `(defun gnus-group-iterate (arg ,function) | 1576 | `(defun gnus-group-iterate (arg ,function) |
| 1467 | "Iterate FUNCTION over all process/prefixed groups. | 1577 | "Iterate FUNCTION over all process/prefixed groups. |
| 1468 | FUNCTION will be called with the group name as the paremeter | 1578 | FUNCTION will be called with the group name as the parameter |
| 1469 | and with point over the group in question." | 1579 | and with point over the group in question." |
| 1470 | (let ((,groups (gnus-group-process-prefix arg)) | 1580 | (let ((,groups (gnus-group-process-prefix arg)) |
| 1471 | (,window (selected-window)) | 1581 | (,window (selected-window)) |
| 1472 | ,group) | 1582 | ,group) |
| 1473 | (while (setq ,group (pop ,groups)) | 1583 | (while ,groups |
| 1584 | (setq ,group (car ,groups) | ||
| 1585 | ,groups (cdr ,groups)) | ||
| 1474 | (select-window ,window) | 1586 | (select-window ,window) |
| 1475 | (gnus-group-remove-mark ,group) | 1587 | (gnus-group-remove-mark ,group) |
| 1476 | (save-selected-window | 1588 | (save-selected-window |
| @@ -1565,7 +1677,7 @@ be permanent." | |||
| 1565 | (defun gnus-fetch-group (group) | 1677 | (defun gnus-fetch-group (group) |
| 1566 | "Start Gnus if necessary and enter GROUP. | 1678 | "Start Gnus if necessary and enter GROUP. |
| 1567 | Returns whether the fetching was successful or not." | 1679 | Returns whether the fetching was successful or not." |
| 1568 | (interactive "sGroup name: ") | 1680 | (interactive (list (completing-read "Group name: " gnus-active-hashtb))) |
| 1569 | (unless (get-buffer gnus-group-buffer) | 1681 | (unless (get-buffer gnus-group-buffer) |
| 1570 | (gnus-no-server)) | 1682 | (gnus-no-server)) |
| 1571 | (gnus-group-read-group nil nil group)) | 1683 | (gnus-group-read-group nil nil group)) |
| @@ -1597,7 +1709,7 @@ ephemeral group. | |||
| 1597 | If REQUEST-ONLY, don't actually read the group; just request it. | 1709 | If REQUEST-ONLY, don't actually read the group; just request it. |
| 1598 | If SELECT-ARTICLES, only select those articles. | 1710 | If SELECT-ARTICLES, only select those articles. |
| 1599 | 1711 | ||
| 1600 | Return the name of the group is selection was successful." | 1712 | Return the name of the group if selection was successful." |
| 1601 | ;; Transform the select method into a unique server. | 1713 | ;; Transform the select method into a unique server. |
| 1602 | (when (stringp method) | 1714 | (when (stringp method) |
| 1603 | (setq method (gnus-server-to-method method))) | 1715 | (setq method (gnus-server-to-method method))) |
| @@ -1654,41 +1766,56 @@ Return the name of the group is selection was successful." | |||
| 1654 | ;; Adjust cursor point. | 1766 | ;; Adjust cursor point. |
| 1655 | (gnus-group-position-point)) | 1767 | (gnus-group-position-point)) |
| 1656 | 1768 | ||
| 1657 | (defun gnus-group-goto-group (group &optional far) | 1769 | (defun gnus-group-goto-group (group &optional far test-marked) |
| 1658 | "Goto to newsgroup GROUP. | 1770 | "Goto to newsgroup GROUP. |
| 1659 | If FAR, it is likely that the group is not on the current line." | 1771 | If FAR, it is likely that the group is not on the current line. |
| 1772 | If TEST-MARKED, the line must be marked." | ||
| 1660 | (when group | 1773 | (when group |
| 1661 | (if far | 1774 | (beginning-of-line) |
| 1662 | (gnus-goto-char | 1775 | (cond |
| 1663 | (text-property-any | 1776 | ;; It's quite likely that we are on the right line, so |
| 1664 | (point-min) (point-max) | 1777 | ;; we check the current line first. |
| 1665 | 'gnus-group (gnus-intern-safe group gnus-active-hashtb))) | 1778 | ((and (not far) |
| 1666 | (beginning-of-line) | 1779 | (eq (get-text-property (point) 'gnus-group) |
| 1667 | (cond | 1780 | (gnus-intern-safe group gnus-active-hashtb)) |
| 1668 | ;; It's quite likely that we are on the right line, so | 1781 | (or (not test-marked) (gnus-group-mark-line-p))) |
| 1669 | ;; we check the current line first. | 1782 | (point)) |
| 1670 | ((eq (get-text-property (point) 'gnus-group) | 1783 | ;; Previous and next line are also likely, so we check them as well. |
| 1671 | (gnus-intern-safe group gnus-active-hashtb)) | 1784 | ((and (not far) |
| 1672 | (point)) | 1785 | (save-excursion |
| 1673 | ;; Previous and next line are also likely, so we check them as well. | 1786 | (forward-line -1) |
| 1674 | ((save-excursion | 1787 | (and (eq (get-text-property (point) 'gnus-group) |
| 1675 | (forward-line -1) | 1788 | (gnus-intern-safe group gnus-active-hashtb)) |
| 1676 | (eq (get-text-property (point) 'gnus-group) | 1789 | (or (not test-marked) (gnus-group-mark-line-p))))) |
| 1677 | (gnus-intern-safe group gnus-active-hashtb))) | 1790 | (forward-line -1) |
| 1678 | (forward-line -1) | 1791 | (point)) |
| 1679 | (point)) | 1792 | ((and (not far) |
| 1680 | ((save-excursion | 1793 | (save-excursion |
| 1681 | (forward-line 1) | 1794 | (forward-line 1) |
| 1682 | (eq (get-text-property (point) 'gnus-group) | 1795 | (and (eq (get-text-property (point) 'gnus-group) |
| 1683 | (gnus-intern-safe group gnus-active-hashtb))) | 1796 | (gnus-intern-safe group gnus-active-hashtb)) |
| 1684 | (forward-line 1) | 1797 | (or (not test-marked) (gnus-group-mark-line-p))))) |
| 1685 | (point)) | 1798 | (forward-line 1) |
| 1686 | (t | 1799 | (point)) |
| 1687 | ;; Search through the entire buffer. | 1800 | (test-marked |
| 1688 | (gnus-goto-char | 1801 | (goto-char (point-min)) |
| 1689 | (text-property-any | 1802 | (let (found) |
| 1690 | (point-min) (point-max) | 1803 | (while (and (not found) |
| 1691 | 'gnus-group (gnus-intern-safe group gnus-active-hashtb)))))))) | 1804 | (gnus-goto-char |
| 1805 | (text-property-any | ||
| 1806 | (point) (point-max) | ||
| 1807 | 'gnus-group | ||
| 1808 | (gnus-intern-safe group gnus-active-hashtb)))) | ||
| 1809 | (if (gnus-group-mark-line-p) | ||
| 1810 | (setq found t) | ||
| 1811 | (forward-line 1))) | ||
| 1812 | found)) | ||
| 1813 | (t | ||
| 1814 | ;; Search through the entire buffer. | ||
| 1815 | (gnus-goto-char | ||
| 1816 | (text-property-any | ||
| 1817 | (point-min) (point-max) | ||
| 1818 | 'gnus-group (gnus-intern-safe group gnus-active-hashtb))))))) | ||
| 1692 | 1819 | ||
| 1693 | (defun gnus-group-next-group (n &optional silent) | 1820 | (defun gnus-group-next-group (n &optional silent) |
| 1694 | "Go to next N'th newsgroup. | 1821 | "Go to next N'th newsgroup. |
| @@ -1804,11 +1931,12 @@ ADDRESS." | |||
| 1804 | (gnus-read-method "From method: "))) | 1931 | (gnus-read-method "From method: "))) |
| 1805 | 1932 | ||
| 1806 | (when (stringp method) | 1933 | (when (stringp method) |
| 1807 | (setq method (gnus-server-to-method method))) | 1934 | (setq method (or (gnus-server-to-method method) method))) |
| 1808 | (let* ((meth (when (and method | 1935 | (let* ((meth (gnus-method-simplify |
| 1809 | (not (gnus-server-equal method gnus-select-method))) | 1936 | (when (and method |
| 1810 | (if address (list (intern method) address) | 1937 | (not (gnus-server-equal method gnus-select-method))) |
| 1811 | method))) | 1938 | (if address (list (intern method) address) |
| 1939 | method)))) | ||
| 1812 | (nname (if method (gnus-group-prefixed-name name meth) name)) | 1940 | (nname (if method (gnus-group-prefixed-name name meth) name)) |
| 1813 | backend info) | 1941 | backend info) |
| 1814 | (when (gnus-gethash nname gnus-newsrc-hashtb) | 1942 | (when (gnus-gethash nname gnus-newsrc-hashtb) |
| @@ -1843,8 +1971,20 @@ ADDRESS." | |||
| 1843 | (gnus-request-create-group nname nil args)) | 1971 | (gnus-request-create-group nname nil args)) |
| 1844 | t)) | 1972 | t)) |
| 1845 | 1973 | ||
| 1846 | (defun gnus-group-delete-group (group &optional force) | 1974 | (defun gnus-group-delete-groups (&optional arg) |
| 1847 | "Delete the current group. Only meaningful with mail groups. | 1975 | "Delete the current group. Only meaningful with editable groups." |
| 1976 | (interactive "P") | ||
| 1977 | (let ((n (length (gnus-group-process-prefix arg)))) | ||
| 1978 | (when (gnus-yes-or-no-p | ||
| 1979 | (if (= n 1) | ||
| 1980 | "Delete this 1 group? " | ||
| 1981 | (format "Delete these %d groups? " n))) | ||
| 1982 | (gnus-group-iterate arg | ||
| 1983 | (lambda (group) | ||
| 1984 | (gnus-group-delete-group group nil t)))))) | ||
| 1985 | |||
| 1986 | (defun gnus-group-delete-group (group &optional force no-prompt) | ||
| 1987 | "Delete the current group. Only meaningful with editable groups. | ||
| 1848 | If FORCE (the prefix) is non-nil, all the articles in the group will | 1988 | If FORCE (the prefix) is non-nil, all the articles in the group will |
| 1849 | be deleted. This is \"deleted\" as in \"removed forever from the face | 1989 | be deleted. This is \"deleted\" as in \"removed forever from the face |
| 1850 | of the Earth\". There is no undo. The user will be prompted before | 1990 | of the Earth\". There is no undo. The user will be prompted before |
| @@ -1857,10 +1997,11 @@ doing the deletion." | |||
| 1857 | (unless (gnus-check-backend-function 'request-delete-group group) | 1997 | (unless (gnus-check-backend-function 'request-delete-group group) |
| 1858 | (error "This backend does not support group deletion")) | 1998 | (error "This backend does not support group deletion")) |
| 1859 | (prog1 | 1999 | (prog1 |
| 1860 | (if (not (gnus-yes-or-no-p | 2000 | (if (and (not no-prompt) |
| 1861 | (format | 2001 | (not (gnus-yes-or-no-p |
| 1862 | "Do you really want to delete %s%s? " | 2002 | (format |
| 1863 | group (if force " and all its contents" "")))) | 2003 | "Do you really want to delete %s%s? " |
| 2004 | group (if force " and all its contents" ""))))) | ||
| 1864 | () ; Whew! | 2005 | () ; Whew! |
| 1865 | (gnus-message 6 "Deleting group %s..." group) | 2006 | (gnus-message 6 "Deleting group %s..." group) |
| 1866 | (if (not (gnus-request-delete-group group force)) | 2007 | (if (not (gnus-request-delete-group group force)) |
| @@ -1905,10 +2046,12 @@ and NEW-NAME will be prompted for." | |||
| 1905 | 2046 | ||
| 1906 | (gnus-message 6 "Renaming group %s to %s..." group new-name) | 2047 | (gnus-message 6 "Renaming group %s to %s..." group new-name) |
| 1907 | (prog1 | 2048 | (prog1 |
| 1908 | (if (not (gnus-request-rename-group group new-name)) | 2049 | (if (progn |
| 2050 | (gnus-group-goto-group group) | ||
| 2051 | (not (when (< (gnus-group-group-level) gnus-level-zombie) | ||
| 2052 | (gnus-request-rename-group group new-name)))) | ||
| 1909 | (gnus-error 3 "Couldn't rename group %s to %s" group new-name) | 2053 | (gnus-error 3 "Couldn't rename group %s to %s" group new-name) |
| 1910 | ;; We rename the group internally by killing it... | 2054 | ;; We rename the group internally by killing it... |
| 1911 | (gnus-group-goto-group group) | ||
| 1912 | (gnus-group-kill-group) | 2055 | (gnus-group-kill-group) |
| 1913 | ;; ... changing its name ... | 2056 | ;; ... changing its name ... |
| 1914 | (setcar (cdar gnus-list-of-killed-groups) new-name) | 2057 | (setcar (cdar gnus-list-of-killed-groups) new-name) |
| @@ -1947,7 +2090,7 @@ and NEW-NAME will be prompted for." | |||
| 1947 | ((eq part 'method) "select method") | 2090 | ((eq part 'method) "select method") |
| 1948 | ((eq part 'params) "group parameters") | 2091 | ((eq part 'params) "group parameters") |
| 1949 | (t "group info")) | 2092 | (t "group info")) |
| 1950 | group) | 2093 | (gnus-group-decoded-name group)) |
| 1951 | `(lambda (form) | 2094 | `(lambda (form) |
| 1952 | (gnus-group-edit-group-done ',part ,group form))))) | 2095 | (gnus-group-edit-group-done ',part ,group form))))) |
| 1953 | 2096 | ||
| @@ -2043,6 +2186,7 @@ and NEW-NAME will be prompted for." | |||
| 2043 | ((= char ?d) 'digest) | 2186 | ((= char ?d) 'digest) |
| 2044 | ((= char ?f) 'forward) | 2187 | ((= char ?f) 'forward) |
| 2045 | ((= char ?a) 'mmfd) | 2188 | ((= char ?a) 'mmfd) |
| 2189 | ((= char ?g) 'guess) | ||
| 2046 | (t (setq err (format "%c unknown. " char)) | 2190 | (t (setq err (format "%c unknown. " char)) |
| 2047 | nil)))) | 2191 | nil)))) |
| 2048 | (setq type found))) | 2192 | (setq type found))) |
| @@ -2093,6 +2237,42 @@ If SOLID (the prefix), create a solid group." | |||
| 2093 | (cons (current-buffer) | 2237 | (cons (current-buffer) |
| 2094 | (if (eq major-mode 'gnus-summary-mode) 'summary 'group)))))) | 2238 | (if (eq major-mode 'gnus-summary-mode) 'summary 'group)))))) |
| 2095 | 2239 | ||
| 2240 | (defvar nnwarchive-type-definition) | ||
| 2241 | (defvar gnus-group-warchive-type-history nil) | ||
| 2242 | (defvar gnus-group-warchive-login-history nil) | ||
| 2243 | (defvar gnus-group-warchive-address-history nil) | ||
| 2244 | |||
| 2245 | (defun gnus-group-make-warchive-group () | ||
| 2246 | "Create a nnwarchive group." | ||
| 2247 | (interactive) | ||
| 2248 | (require 'nnwarchive) | ||
| 2249 | (let* ((group (gnus-read-group "Group name: ")) | ||
| 2250 | (default-type (or (car gnus-group-warchive-type-history) | ||
| 2251 | (symbol-name (caar nnwarchive-type-definition)))) | ||
| 2252 | (type | ||
| 2253 | (gnus-string-or | ||
| 2254 | (completing-read | ||
| 2255 | (format "Warchive type (default %s): " default-type) | ||
| 2256 | (mapcar (lambda (elem) (list (symbol-name (car elem)))) | ||
| 2257 | nnwarchive-type-definition) | ||
| 2258 | nil t nil 'gnus-group-warchive-type-history) | ||
| 2259 | default-type)) | ||
| 2260 | (address (read-string "Warchive address: " | ||
| 2261 | nil 'gnus-group-warchive-address-history)) | ||
| 2262 | (default-login (or (car gnus-group-warchive-login-history) | ||
| 2263 | user-mail-address)) | ||
| 2264 | (login | ||
| 2265 | (gnus-string-or | ||
| 2266 | (read-string | ||
| 2267 | (format "Warchive login (default %s): " user-mail-address) | ||
| 2268 | default-login 'gnus-group-warchive-login-history) | ||
| 2269 | user-mail-address)) | ||
| 2270 | (method | ||
| 2271 | `(nnwarchive ,address | ||
| 2272 | (nnwarchive-type ,(intern type)) | ||
| 2273 | (nnwarchive-login ,login)))) | ||
| 2274 | (gnus-group-make-group group method))) | ||
| 2275 | |||
| 2096 | (defun gnus-group-make-archive-group (&optional all) | 2276 | (defun gnus-group-make-archive-group (&optional all) |
| 2097 | "Create the (ding) Gnus archive group of the most recent articles. | 2277 | "Create the (ding) Gnus archive group of the most recent articles. |
| 2098 | Given a prefix, create a full group." | 2278 | Given a prefix, create a full group." |
| @@ -2157,9 +2337,13 @@ score file entries for articles to include in the group." | |||
| 2157 | (push (cons header regexps) scores)) | 2337 | (push (cons header regexps) scores)) |
| 2158 | scores))) | 2338 | scores))) |
| 2159 | (gnus-group-make-group group "nnkiboze" address) | 2339 | (gnus-group-make-group group "nnkiboze" address) |
| 2160 | (nnheader-temp-write (gnus-score-file-name (concat "nnkiboze:" group)) | 2340 | (let* ((score-file (gnus-score-file-name (concat "nnkiboze:" group))) |
| 2161 | (let (emacs-lisp-mode-hook) | 2341 | (score-dir (file-name-directory score-file))) |
| 2162 | (pp scores (current-buffer))))) | 2342 | (unless (file-exists-p score-dir) |
| 2343 | (make-directory score-dir)) | ||
| 2344 | (with-temp-file score-file | ||
| 2345 | (let (emacs-lisp-mode-hook) | ||
| 2346 | (pp scores (current-buffer)))))) | ||
| 2163 | 2347 | ||
| 2164 | (defun gnus-group-add-to-virtual (n vgroup) | 2348 | (defun gnus-group-add-to-virtual (n vgroup) |
| 2165 | "Add the current group to a virtual group." | 2349 | "Add the current group to a virtual group." |
| @@ -2211,6 +2395,62 @@ score file entries for articles to include in the group." | |||
| 2211 | 'summary 'group))) | 2395 | 'summary 'group))) |
| 2212 | (error "Couldn't enter %s" dir)))) | 2396 | (error "Couldn't enter %s" dir)))) |
| 2213 | 2397 | ||
| 2398 | (eval-and-compile | ||
| 2399 | (autoload 'nnimap-expunge "nnimap") | ||
| 2400 | (autoload 'nnimap-acl-get "nnimap") | ||
| 2401 | (autoload 'nnimap-acl-edit "nnimap")) | ||
| 2402 | |||
| 2403 | (defun gnus-group-nnimap-expunge (group) | ||
| 2404 | "Expunge deleted articles in current nnimap GROUP." | ||
| 2405 | (interactive (list (gnus-group-group-name))) | ||
| 2406 | (let ((mailbox (gnus-group-real-name group)) method) | ||
| 2407 | (unless group | ||
| 2408 | (error "No group on current line")) | ||
| 2409 | (unless (gnus-get-info group) | ||
| 2410 | (error "Killed group; can't be edited")) | ||
| 2411 | (unless (eq 'nnimap (car (setq method (gnus-find-method-for-group group)))) | ||
| 2412 | (error "%s is not an nnimap group" group)) | ||
| 2413 | (nnimap-expunge mailbox (cadr method)))) | ||
| 2414 | |||
| 2415 | (defun gnus-group-nnimap-edit-acl (group) | ||
| 2416 | "Edit the Access Control List of current nnimap GROUP." | ||
| 2417 | (interactive (list (gnus-group-group-name))) | ||
| 2418 | (let ((mailbox (gnus-group-real-name group)) method acl) | ||
| 2419 | (unless group | ||
| 2420 | (error "No group on current line")) | ||
| 2421 | (unless (gnus-get-info group) | ||
| 2422 | (error "Killed group; can't be edited")) | ||
| 2423 | (unless (eq (car (setq method (gnus-find-method-for-group group))) 'nnimap) | ||
| 2424 | (error "%s is not an nnimap group" group)) | ||
| 2425 | (gnus-edit-form (setq acl (nnimap-acl-get mailbox (cadr method))) | ||
| 2426 | (format "Editing the access control list for `%s'. | ||
| 2427 | |||
| 2428 | An access control list is a list of (identifier . rights) elements. | ||
| 2429 | |||
| 2430 | The identifier string specifies the corresponding user. The | ||
| 2431 | identifier \"anyone\" is reserved to refer to the universal identity. | ||
| 2432 | |||
| 2433 | Rights is a string listing a (possibly empty) set of alphanumeric | ||
| 2434 | characters, each character listing a set of operations which is being | ||
| 2435 | controlled. Letters are reserved for ``standard'' rights, listed | ||
| 2436 | below. Digits are reserved for implementation or site defined rights. | ||
| 2437 | |||
| 2438 | l - lookup (mailbox is visible to LIST/LSUB commands) | ||
| 2439 | r - read (SELECT the mailbox, perform CHECK, FETCH, PARTIAL, | ||
| 2440 | SEARCH, COPY from mailbox) | ||
| 2441 | s - keep seen/unseen information across sessions (STORE \\SEEN flag) | ||
| 2442 | w - write (STORE flags other than \\SEEN and \\DELETED) | ||
| 2443 | i - insert (perform APPEND, COPY into mailbox) | ||
| 2444 | p - post (send mail to submission address for mailbox, | ||
| 2445 | not enforced by IMAP4 itself) | ||
| 2446 | c - create and delete mailbox (CREATE new sub-mailboxes in any | ||
| 2447 | implementation-defined hierarchy, RENAME or DELETE mailbox) | ||
| 2448 | d - delete messages (STORE \\DELETED flag, perform EXPUNGE) | ||
| 2449 | a - administer (perform SETACL)" group) | ||
| 2450 | `(lambda (form) | ||
| 2451 | (nnimap-acl-edit | ||
| 2452 | ,mailbox ',method ',acl form))))) | ||
| 2453 | |||
| 2214 | ;; Group sorting commands | 2454 | ;; Group sorting commands |
| 2215 | ;; Suggested by Joe Hildebrand <hildjj@idaho.fuentez.com>. | 2455 | ;; Suggested by Joe Hildebrand <hildjj@idaho.fuentez.com>. |
| 2216 | 2456 | ||
| @@ -2302,46 +2542,52 @@ If REVERSE, sort in reverse order." | |||
| 2302 | ;; Go through all the infos and replace the old entries | 2542 | ;; Go through all the infos and replace the old entries |
| 2303 | ;; with the new infos. | 2543 | ;; with the new infos. |
| 2304 | (while infos | 2544 | (while infos |
| 2305 | (setcar entries (pop infos)) | 2545 | (setcar (car entries) (pop infos)) |
| 2306 | (pop entries)) | 2546 | (pop entries)) |
| 2307 | ;; Update the hashtable. | 2547 | ;; Update the hashtable. |
| 2308 | (gnus-make-hashtable-from-newsrc-alist))) | 2548 | (gnus-make-hashtable-from-newsrc-alist))) |
| 2309 | 2549 | ||
| 2310 | (defun gnus-group-sort-selected-groups-by-alphabet (&optional reverse) | 2550 | (defun gnus-group-sort-selected-groups-by-alphabet (&optional n reverse) |
| 2311 | "Sort the group buffer alphabetically by group name. | 2551 | "Sort the group buffer alphabetically by group name. |
| 2312 | If REVERSE, sort in reverse order." | 2552 | Obeys the process/prefix convention. If REVERSE (the symbolic prefix), |
| 2313 | (interactive "P") | 2553 | sort in reverse order." |
| 2314 | (gnus-group-sort-selected-groups 'gnus-group-sort-by-alphabet reverse)) | 2554 | (interactive (gnus-interactive "P\ny")) |
| 2555 | (gnus-group-sort-selected-groups n 'gnus-group-sort-by-alphabet reverse)) | ||
| 2315 | 2556 | ||
| 2316 | (defun gnus-group-sort-selected-groups-by-unread (&optional reverse) | 2557 | (defun gnus-group-sort-selected-groups-by-unread (&optional n reverse) |
| 2317 | "Sort the group buffer by number of unread articles. | 2558 | "Sort the group buffer by number of unread articles. |
| 2318 | If REVERSE, sort in reverse order." | 2559 | Obeys the process/prefix convention. If REVERSE (the symbolic prefix), |
| 2319 | (interactive "P") | 2560 | sort in reverse order." |
| 2320 | (gnus-group-sort-selected-groups 'gnus-group-sort-by-unread reverse)) | 2561 | (interactive (gnus-interactive "P\ny")) |
| 2562 | (gnus-group-sort-selected-groups n 'gnus-group-sort-by-unread reverse)) | ||
| 2321 | 2563 | ||
| 2322 | (defun gnus-group-sort-selected-groups-by-level (&optional reverse) | 2564 | (defun gnus-group-sort-selected-groups-by-level (&optional n reverse) |
| 2323 | "Sort the group buffer by group level. | 2565 | "Sort the group buffer by group level. |
| 2324 | If REVERSE, sort in reverse order." | 2566 | Obeys the process/prefix convention. If REVERSE (the symbolic prefix), |
| 2325 | (interactive "P") | 2567 | sort in reverse order." |
| 2326 | (gnus-group-sort-selected-groups 'gnus-group-sort-by-level reverse)) | 2568 | (interactive (gnus-interactive "P\ny")) |
| 2569 | (gnus-group-sort-selected-groups n 'gnus-group-sort-by-level reverse)) | ||
| 2327 | 2570 | ||
| 2328 | (defun gnus-group-sort-selected-groups-by-score (&optional reverse) | 2571 | (defun gnus-group-sort-selected-groups-by-score (&optional n reverse) |
| 2329 | "Sort the group buffer by group score. | 2572 | "Sort the group buffer by group score. |
| 2330 | If REVERSE, sort in reverse order." | 2573 | Obeys the process/prefix convention. If REVERSE (the symbolic prefix), |
| 2331 | (interactive "P") | 2574 | sort in reverse order." |
| 2332 | (gnus-group-sort-selected-groups 'gnus-group-sort-by-score reverse)) | 2575 | (interactive (gnus-interactive "P\ny")) |
| 2576 | (gnus-group-sort-selected-groups n 'gnus-group-sort-by-score reverse)) | ||
| 2333 | 2577 | ||
| 2334 | (defun gnus-group-sort-selected-groups-by-rank (&optional reverse) | 2578 | (defun gnus-group-sort-selected-groups-by-rank (&optional n reverse) |
| 2335 | "Sort the group buffer by group rank. | 2579 | "Sort the group buffer by group rank. |
| 2336 | If REVERSE, sort in reverse order." | 2580 | Obeys the process/prefix convention. If REVERSE (the symbolic prefix), |
| 2337 | (interactive "P") | 2581 | sort in reverse order." |
| 2338 | (gnus-group-sort-selected-groups 'gnus-group-sort-by-rank reverse)) | 2582 | (interactive (gnus-interactive "P\ny")) |
| 2583 | (gnus-group-sort-selected-groups n 'gnus-group-sort-by-rank reverse)) | ||
| 2339 | 2584 | ||
| 2340 | (defun gnus-group-sort-selected-groups-by-method (&optional reverse) | 2585 | (defun gnus-group-sort-selected-groups-by-method (&optional n reverse) |
| 2341 | "Sort the group buffer alphabetically by backend name. | 2586 | "Sort the group buffer alphabetically by backend name. |
| 2342 | If REVERSE, sort in reverse order." | 2587 | Obeys the process/prefix convention. If REVERSE (the symbolic prefix), |
| 2343 | (interactive "P") | 2588 | sort in reverse order." |
| 2344 | (gnus-group-sort-selected-groups 'gnus-group-sort-by-method reverse)) | 2589 | (interactive (gnus-interactive "P\ny")) |
| 2590 | (gnus-group-sort-selected-groups n 'gnus-group-sort-by-method reverse)) | ||
| 2345 | 2591 | ||
| 2346 | ;;; Sorting predicates. | 2592 | ;;; Sorting predicates. |
| 2347 | 2593 | ||
| @@ -2428,7 +2674,7 @@ If REVERSE, sort in reverse order." | |||
| 2428 | ;; Group catching up. | 2674 | ;; Group catching up. |
| 2429 | 2675 | ||
| 2430 | (defun gnus-group-catchup-current (&optional n all) | 2676 | (defun gnus-group-catchup-current (&optional n all) |
| 2431 | "Mark all articles not marked as unread in current newsgroup as read. | 2677 | "Mark all unread articles in the current newsgroup as read. |
| 2432 | If prefix argument N is numeric, the next N newsgroups will be | 2678 | If prefix argument N is numeric, the next N newsgroups will be |
| 2433 | caught up. If ALL is non-nil, marked articles will also be marked as | 2679 | caught up. If ALL is non-nil, marked articles will also be marked as |
| 2434 | read. Cross references (Xref: header) of articles are ignored. | 2680 | read. Cross references (Xref: header) of articles are ignored. |
| @@ -2436,7 +2682,8 @@ The number of newsgroups that this function was unable to catch | |||
| 2436 | up is returned." | 2682 | up is returned." |
| 2437 | (interactive "P") | 2683 | (interactive "P") |
| 2438 | (let ((groups (gnus-group-process-prefix n)) | 2684 | (let ((groups (gnus-group-process-prefix n)) |
| 2439 | (ret 0)) | 2685 | (ret 0) |
| 2686 | group) | ||
| 2440 | (unless groups (error "No groups selected")) | 2687 | (unless groups (error "No groups selected")) |
| 2441 | (if (not | 2688 | (if (not |
| 2442 | (or (not gnus-interactive-catchup) ;Without confirmation? | 2689 | (or (not gnus-interactive-catchup) ;Without confirmation? |
| @@ -2450,21 +2697,20 @@ up is returned." | |||
| 2450 | (car groups) | 2697 | (car groups) |
| 2451 | (format "these %d groups" (length groups))))))) | 2698 | (format "these %d groups" (length groups))))))) |
| 2452 | n | 2699 | n |
| 2453 | (while groups | 2700 | (while (setq group (pop groups)) |
| 2701 | (gnus-group-remove-mark group) | ||
| 2454 | ;; Virtual groups have to be given special treatment. | 2702 | ;; Virtual groups have to be given special treatment. |
| 2455 | (let ((method (gnus-find-method-for-group (car groups)))) | 2703 | (let ((method (gnus-find-method-for-group group))) |
| 2456 | (when (eq 'nnvirtual (car method)) | 2704 | (when (eq 'nnvirtual (car method)) |
| 2457 | (nnvirtual-catchup-group | 2705 | (nnvirtual-catchup-group |
| 2458 | (gnus-group-real-name (car groups)) (nth 1 method) all))) | 2706 | (gnus-group-real-name group) (nth 1 method) all))) |
| 2459 | (gnus-group-remove-mark (car groups)) | 2707 | (if (>= (gnus-group-level group) gnus-level-zombie) |
| 2460 | (if (>= (gnus-group-group-level) gnus-level-zombie) | ||
| 2461 | (gnus-message 2 "Dead groups can't be caught up") | 2708 | (gnus-message 2 "Dead groups can't be caught up") |
| 2462 | (if (prog1 | 2709 | (if (prog1 |
| 2463 | (gnus-group-goto-group (car groups)) | 2710 | (gnus-group-goto-group group) |
| 2464 | (gnus-group-catchup (car groups) all)) | 2711 | (gnus-group-catchup group all)) |
| 2465 | (gnus-group-update-group-line) | 2712 | (gnus-group-update-group-line) |
| 2466 | (setq ret (1+ ret)))) | 2713 | (setq ret (1+ ret))))) |
| 2467 | (setq groups (cdr groups))) | ||
| 2468 | (gnus-group-next-unread-group 1) | 2714 | (gnus-group-next-unread-group 1) |
| 2469 | ret))) | 2715 | ret))) |
| 2470 | 2716 | ||
| @@ -2481,6 +2727,8 @@ The return value is the number of articles that were marked as read, | |||
| 2481 | or nil if no action could be taken." | 2727 | or nil if no action could be taken." |
| 2482 | (let* ((entry (gnus-gethash group gnus-newsrc-hashtb)) | 2728 | (let* ((entry (gnus-gethash group gnus-newsrc-hashtb)) |
| 2483 | (num (car entry))) | 2729 | (num (car entry))) |
| 2730 | ;; Remove entries for this group. | ||
| 2731 | (nnmail-purge-split-history (gnus-group-real-name group)) | ||
| 2484 | ;; Do the updating only if the newsgroup isn't killed. | 2732 | ;; Do the updating only if the newsgroup isn't killed. |
| 2485 | (if (not (numberp (car entry))) | 2733 | (if (not (numberp (car entry))) |
| 2486 | (gnus-message 1 "Can't catch up %s; non-active group" group) | 2734 | (gnus-message 1 "Can't catch up %s; non-active group" group) |
| @@ -2513,32 +2761,41 @@ or nil if no action could be taken." | |||
| 2513 | (error "No groups to expire")) | 2761 | (error "No groups to expire")) |
| 2514 | (while (setq group (pop groups)) | 2762 | (while (setq group (pop groups)) |
| 2515 | (gnus-group-remove-mark group) | 2763 | (gnus-group-remove-mark group) |
| 2516 | (when (gnus-check-backend-function 'request-expire-articles group) | 2764 | (gnus-group-expire-articles-1 group) |
| 2517 | (gnus-message 6 "Expiring articles in %s..." group) | ||
| 2518 | (let* ((info (gnus-get-info group)) | ||
| 2519 | (expirable (if (gnus-group-total-expirable-p group) | ||
| 2520 | (cons nil (gnus-list-of-read-articles group)) | ||
| 2521 | (assq 'expire (gnus-info-marks info)))) | ||
| 2522 | (expiry-wait (gnus-group-find-parameter group 'expiry-wait))) | ||
| 2523 | (when expirable | ||
| 2524 | (setcdr | ||
| 2525 | expirable | ||
| 2526 | (gnus-compress-sequence | ||
| 2527 | (if expiry-wait | ||
| 2528 | ;; We set the expiry variables to the group | ||
| 2529 | ;; parameter. | ||
| 2530 | (let ((nnmail-expiry-wait-function nil) | ||
| 2531 | (nnmail-expiry-wait expiry-wait)) | ||
| 2532 | (gnus-request-expire-articles | ||
| 2533 | (gnus-uncompress-sequence (cdr expirable)) group)) | ||
| 2534 | ;; Just expire using the normal expiry values. | ||
| 2535 | (gnus-request-expire-articles | ||
| 2536 | (gnus-uncompress-sequence (cdr expirable)) group)))) | ||
| 2537 | (gnus-close-group group)) | ||
| 2538 | (gnus-message 6 "Expiring articles in %s...done" group))) | ||
| 2539 | (gnus-dribble-touch) | 2765 | (gnus-dribble-touch) |
| 2540 | (gnus-group-position-point)))) | 2766 | (gnus-group-position-point)))) |
| 2541 | 2767 | ||
| 2768 | (defun gnus-group-expire-articles-1 (group) | ||
| 2769 | (when (gnus-check-backend-function 'request-expire-articles group) | ||
| 2770 | (gnus-message 6 "Expiring articles in %s..." group) | ||
| 2771 | (let* ((info (gnus-get-info group)) | ||
| 2772 | (expirable (if (gnus-group-total-expirable-p group) | ||
| 2773 | (cons nil (gnus-list-of-read-articles group)) | ||
| 2774 | (assq 'expire (gnus-info-marks info)))) | ||
| 2775 | (expiry-wait (gnus-group-find-parameter group 'expiry-wait)) | ||
| 2776 | (nnmail-expiry-target | ||
| 2777 | (or (gnus-group-find-parameter group 'expiry-target) | ||
| 2778 | nnmail-expiry-target))) | ||
| 2779 | (when expirable | ||
| 2780 | (gnus-check-group group) | ||
| 2781 | (setcdr | ||
| 2782 | expirable | ||
| 2783 | (gnus-compress-sequence | ||
| 2784 | (if expiry-wait | ||
| 2785 | ;; We set the expiry variables to the group | ||
| 2786 | ;; parameter. | ||
| 2787 | (let ((nnmail-expiry-wait-function nil) | ||
| 2788 | (nnmail-expiry-wait expiry-wait)) | ||
| 2789 | (gnus-request-expire-articles | ||
| 2790 | (gnus-uncompress-sequence (cdr expirable)) group)) | ||
| 2791 | ;; Just expire using the normal expiry values. | ||
| 2792 | (gnus-request-expire-articles | ||
| 2793 | (gnus-uncompress-sequence (cdr expirable)) group)))) | ||
| 2794 | (gnus-close-group group)) | ||
| 2795 | (gnus-message 6 "Expiring articles in %s...done" group) | ||
| 2796 | ;; Return the list of un-expired articles. | ||
| 2797 | (cdr expirable)))) | ||
| 2798 | |||
| 2542 | (defun gnus-group-expire-all-groups () | 2799 | (defun gnus-group-expire-all-groups () |
| 2543 | "Expire all expirable articles in all newsgroups." | 2800 | "Expire all expirable articles in all newsgroups." |
| 2544 | (interactive) | 2801 | (interactive) |
| @@ -2565,7 +2822,7 @@ or nil if no action could be taken." | |||
| 2565 | gnus-level-default-subscribed)) | 2822 | gnus-level-default-subscribed)) |
| 2566 | s))))) | 2823 | s))))) |
| 2567 | (unless (and (>= level 1) (<= level gnus-level-killed)) | 2824 | (unless (and (>= level 1) (<= level gnus-level-killed)) |
| 2568 | (error "Illegal level: %d" level)) | 2825 | (error "Invalid level: %d" level)) |
| 2569 | (let ((groups (gnus-group-process-prefix n)) | 2826 | (let ((groups (gnus-group-process-prefix n)) |
| 2570 | group) | 2827 | group) |
| 2571 | (while (setq group (pop groups)) | 2828 | (while (setq group (pop groups)) |
| @@ -2666,13 +2923,15 @@ N and the number of steps taken is returned." | |||
| 2666 | (gnus-group-yank-group) | 2923 | (gnus-group-yank-group) |
| 2667 | (gnus-group-position-point))) | 2924 | (gnus-group-position-point))) |
| 2668 | 2925 | ||
| 2669 | (defun gnus-group-kill-all-zombies () | 2926 | (defun gnus-group-kill-all-zombies (&optional dummy) |
| 2670 | "Kill all zombie newsgroups." | 2927 | "Kill all zombie newsgroups. |
| 2671 | (interactive) | 2928 | The optional DUMMY should always be nil." |
| 2672 | (setq gnus-killed-list (nconc gnus-zombie-list gnus-killed-list)) | 2929 | (interactive (list (not (gnus-yes-or-no-p "Really kill all zombies? ")))) |
| 2673 | (setq gnus-zombie-list nil) | 2930 | (unless dummy |
| 2674 | (gnus-dribble-touch) | 2931 | (setq gnus-killed-list (nconc gnus-zombie-list gnus-killed-list)) |
| 2675 | (gnus-group-list-groups)) | 2932 | (setq gnus-zombie-list nil) |
| 2933 | (gnus-dribble-touch) | ||
| 2934 | (gnus-group-list-groups))) | ||
| 2676 | 2935 | ||
| 2677 | (defun gnus-group-kill-region (begin end) | 2936 | (defun gnus-group-kill-region (begin end) |
| 2678 | "Kill newsgroups in current region (excluding current point). | 2937 | "Kill newsgroups in current region (excluding current point). |
| @@ -2721,7 +2980,8 @@ of groups killed." | |||
| 2721 | (push (cons (car entry) (nth 2 entry)) | 2980 | (push (cons (car entry) (nth 2 entry)) |
| 2722 | gnus-list-of-killed-groups)) | 2981 | gnus-list-of-killed-groups)) |
| 2723 | (gnus-group-change-level | 2982 | (gnus-group-change-level |
| 2724 | (if entry entry group) gnus-level-killed (if entry nil level))) | 2983 | (if entry entry group) gnus-level-killed (if entry nil level)) |
| 2984 | (message "Killed group %s" group)) | ||
| 2725 | ;; If there are lots and lots of groups to be killed, we use | 2985 | ;; If there are lots and lots of groups to be killed, we use |
| 2726 | ;; this thing instead. | 2986 | ;; this thing instead. |
| 2727 | (let (entry) | 2987 | (let (entry) |
| @@ -2807,7 +3067,7 @@ yanked) a list of yanked groups is returned." | |||
| 2807 | (gnus-make-hashtable-from-newsrc-alist) | 3067 | (gnus-make-hashtable-from-newsrc-alist) |
| 2808 | (gnus-group-list-groups))) | 3068 | (gnus-group-list-groups))) |
| 2809 | (t | 3069 | (t |
| 2810 | (error "Can't kill; illegal level: %d" level)))) | 3070 | (error "Can't kill; invalid level: %d" level)))) |
| 2811 | 3071 | ||
| 2812 | (defun gnus-group-list-all-groups (&optional arg) | 3072 | (defun gnus-group-list-all-groups (&optional arg) |
| 2813 | "List all newsgroups with level ARG or lower. | 3073 | "List all newsgroups with level ARG or lower. |
| @@ -2850,7 +3110,8 @@ entail asking the server for the groups." | |||
| 2850 | (interactive) | 3110 | (interactive) |
| 2851 | ;; First we make sure that we have really read the active file. | 3111 | ;; First we make sure that we have really read the active file. |
| 2852 | (unless (gnus-read-active-file-p) | 3112 | (unless (gnus-read-active-file-p) |
| 2853 | (let ((gnus-read-active-file t)) | 3113 | (let ((gnus-read-active-file t) |
| 3114 | (gnus-agent nil)) ; Trick the agent into ignoring the active file. | ||
| 2854 | (gnus-read-active-file))) | 3115 | (gnus-read-active-file))) |
| 2855 | ;; Find all groups and sort them. | 3116 | ;; Find all groups and sort them. |
| 2856 | (let ((groups | 3117 | (let ((groups |
| @@ -2868,10 +3129,14 @@ entail asking the server for the groups." | |||
| 2868 | group) | 3129 | group) |
| 2869 | (erase-buffer) | 3130 | (erase-buffer) |
| 2870 | (while groups | 3131 | (while groups |
| 3132 | (setq group (pop groups)) | ||
| 2871 | (gnus-add-text-properties | 3133 | (gnus-add-text-properties |
| 2872 | (point) (prog1 (1+ (point)) | 3134 | (point) (prog1 (1+ (point)) |
| 2873 | (insert " *: " | 3135 | (insert " *: " |
| 2874 | (setq group (pop groups)) "\n")) | 3136 | (gnus-group-name-decode group |
| 3137 | (gnus-group-name-charset | ||
| 3138 | nil group)) | ||
| 3139 | "\n")) | ||
| 2875 | (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb) | 3140 | (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb) |
| 2876 | 'gnus-unread t | 3141 | 'gnus-unread t |
| 2877 | 'gnus-level (inline (gnus-group-level group))))) | 3142 | 'gnus-level (inline (gnus-group-level group))))) |
| @@ -2890,7 +3155,11 @@ If ARG is a number, it specifies which levels you are interested in | |||
| 2890 | re-scanning. If ARG is non-nil and not a number, this will force | 3155 | re-scanning. If ARG is non-nil and not a number, this will force |
| 2891 | \"hard\" re-reading of the active files from all servers." | 3156 | \"hard\" re-reading of the active files from all servers." |
| 2892 | (interactive "P") | 3157 | (interactive "P") |
| 2893 | (let ((gnus-inhibit-demon t)) | 3158 | (require 'nnmail) |
| 3159 | (let ((gnus-inhibit-demon t) | ||
| 3160 | ;; Binding this variable will inhibit multiple fetchings | ||
| 3161 | ;; of the same mail source. | ||
| 3162 | (nnmail-fetched-sources (list t))) | ||
| 2894 | (gnus-run-hooks 'gnus-get-new-news-hook) | 3163 | (gnus-run-hooks 'gnus-get-new-news-hook) |
| 2895 | 3164 | ||
| 2896 | ;; Read any slave files. | 3165 | ;; Read any slave files. |
| @@ -2931,7 +3200,12 @@ If N is negative, this group and the N-1 previous groups will be checked." | |||
| 2931 | (ret (if (numberp n) (- n (length groups)) 0)) | 3200 | (ret (if (numberp n) (- n (length groups)) 0)) |
| 2932 | (beg (unless n | 3201 | (beg (unless n |
| 2933 | (point))) | 3202 | (point))) |
| 2934 | group method) | 3203 | group method |
| 3204 | (gnus-inhibit-demon t) | ||
| 3205 | ;; Binding this variable will inhibit multiple fetchings | ||
| 3206 | ;; of the same mail source. | ||
| 3207 | (nnmail-fetched-sources (list t))) | ||
| 3208 | (gnus-run-hooks 'gnus-get-new-news-hook) | ||
| 2935 | (while (setq group (pop groups)) | 3209 | (while (setq group (pop groups)) |
| 2936 | (gnus-group-remove-mark group) | 3210 | (gnus-group-remove-mark group) |
| 2937 | ;; Bypass any previous denials from the server. | 3211 | ;; Bypass any previous denials from the server. |
| @@ -2942,8 +3216,9 @@ If N is negative, this group and the N-1 previous groups will be checked." | |||
| 2942 | (gnus-get-info group) (gnus-active group) t) | 3216 | (gnus-get-info group) (gnus-active group) t) |
| 2943 | (unless (gnus-virtual-group-p group) | 3217 | (unless (gnus-virtual-group-p group) |
| 2944 | (gnus-close-group group)) | 3218 | (gnus-close-group group)) |
| 2945 | (gnus-agent-save-group-info | 3219 | (when gnus-agent |
| 2946 | method (gnus-group-real-name group) (gnus-active group)) | 3220 | (gnus-agent-save-group-info |
| 3221 | method (gnus-group-real-name group) (gnus-active group))) | ||
| 2947 | (gnus-group-update-group group)) | 3222 | (gnus-group-update-group group)) |
| 2948 | (if (eq (gnus-server-status (gnus-find-method-for-group group)) | 3223 | (if (eq (gnus-server-status (gnus-find-method-for-group group)) |
| 2949 | 'denied) | 3224 | 'denied) |
| @@ -3020,8 +3295,12 @@ to use." | |||
| 3020 | (mapatoms | 3295 | (mapatoms |
| 3021 | (lambda (group) | 3296 | (lambda (group) |
| 3022 | (setq b (point)) | 3297 | (setq b (point)) |
| 3023 | (insert (format " *: %-20s %s\n" (symbol-name group) | 3298 | (let ((charset (gnus-group-name-charset nil (symbol-name group)))) |
| 3024 | (symbol-value group))) | 3299 | (insert (format " *: %-20s %s\n" |
| 3300 | (gnus-group-name-decode | ||
| 3301 | (symbol-name group) charset) | ||
| 3302 | (gnus-group-name-decode | ||
| 3303 | (symbol-value group) charset)))) | ||
| 3025 | (gnus-add-text-properties | 3304 | (gnus-add-text-properties |
| 3026 | b (1+ b) (list 'gnus-group group | 3305 | b (1+ b) (list 'gnus-group group |
| 3027 | 'gnus-unread t 'gnus-marked nil | 3306 | 'gnus-unread t 'gnus-marked nil |
| @@ -3057,17 +3336,19 @@ to use." | |||
| 3057 | ;; Print out all the groups. | 3336 | ;; Print out all the groups. |
| 3058 | (save-excursion | 3337 | (save-excursion |
| 3059 | (pop-to-buffer "*Gnus Help*") | 3338 | (pop-to-buffer "*Gnus Help*") |
| 3060 | (buffer-disable-undo (current-buffer)) | 3339 | (buffer-disable-undo) |
| 3061 | (erase-buffer) | 3340 | (erase-buffer) |
| 3062 | (setq groups (sort groups 'string<)) | 3341 | (setq groups (sort groups 'string<)) |
| 3063 | (while groups | 3342 | (while groups |
| 3064 | ;; Groups may be entered twice into the list of groups. | 3343 | ;; Groups may be entered twice into the list of groups. |
| 3065 | (when (not (string= (car groups) prev)) | 3344 | (when (not (string= (car groups) prev)) |
| 3066 | (insert (setq prev (car groups)) "\n") | 3345 | (setq prev (car groups)) |
| 3067 | (when (and gnus-description-hashtb | 3346 | (let ((charset (gnus-group-name-charset nil prev))) |
| 3068 | (setq des (gnus-gethash (car groups) | 3347 | (insert (gnus-group-name-decode prev charset) "\n") |
| 3069 | gnus-description-hashtb))) | 3348 | (when (and gnus-description-hashtb |
| 3070 | (insert " " des "\n"))) | 3349 | (setq des (gnus-gethash (car groups) |
| 3350 | gnus-description-hashtb))) | ||
| 3351 | (insert " " (gnus-group-name-decode des charset) "\n")))) | ||
| 3071 | (setq groups (cdr groups))) | 3352 | (setq groups (cdr groups))) |
| 3072 | (goto-char (point-min)))) | 3353 | (goto-char (point-min)))) |
| 3073 | (pop-to-buffer obuf))) | 3354 | (pop-to-buffer obuf))) |
| @@ -3267,59 +3548,60 @@ and the second element is the address." | |||
| 3267 | (gnus-browse-foreign-server method)) | 3548 | (gnus-browse-foreign-server method)) |
| 3268 | 3549 | ||
| 3269 | (defun gnus-group-set-info (info &optional method-only-group part) | 3550 | (defun gnus-group-set-info (info &optional method-only-group part) |
| 3270 | (let* ((entry (gnus-gethash | 3551 | (when (or info part) |
| 3271 | (or method-only-group (gnus-info-group info)) | 3552 | (let* ((entry (gnus-gethash |
| 3272 | gnus-newsrc-hashtb)) | 3553 | (or method-only-group (gnus-info-group info)) |
| 3273 | (part-info info) | 3554 | gnus-newsrc-hashtb)) |
| 3274 | (info (if method-only-group (nth 2 entry) info)) | 3555 | (part-info info) |
| 3275 | method) | 3556 | (info (if method-only-group (nth 2 entry) info)) |
| 3276 | (when method-only-group | 3557 | method) |
| 3558 | (when method-only-group | ||
| 3559 | (unless entry | ||
| 3560 | (error "Trying to change non-existent group %s" method-only-group)) | ||
| 3561 | ;; We have received parts of the actual group info - either the | ||
| 3562 | ;; select method or the group parameters. We first check | ||
| 3563 | ;; whether we have to extend the info, and if so, do that. | ||
| 3564 | (let ((len (length info)) | ||
| 3565 | (total (if (eq part 'method) 5 6))) | ||
| 3566 | (when (< len total) | ||
| 3567 | (setcdr (nthcdr (1- len) info) | ||
| 3568 | (make-list (- total len) nil))) | ||
| 3569 | ;; Then we enter the new info. | ||
| 3570 | (setcar (nthcdr (1- total) info) part-info))) | ||
| 3277 | (unless entry | 3571 | (unless entry |
| 3278 | (error "Trying to change non-existent group %s" method-only-group)) | 3572 | ;; This is a new group, so we just create it. |
| 3279 | ;; We have received parts of the actual group info - either the | ||
| 3280 | ;; select method or the group parameters. We first check | ||
| 3281 | ;; whether we have to extend the info, and if so, do that. | ||
| 3282 | (let ((len (length info)) | ||
| 3283 | (total (if (eq part 'method) 5 6))) | ||
| 3284 | (when (< len total) | ||
| 3285 | (setcdr (nthcdr (1- len) info) | ||
| 3286 | (make-list (- total len) nil))) | ||
| 3287 | ;; Then we enter the new info. | ||
| 3288 | (setcar (nthcdr (1- total) info) part-info))) | ||
| 3289 | (unless entry | ||
| 3290 | ;; This is a new group, so we just create it. | ||
| 3291 | (save-excursion | ||
| 3292 | (set-buffer gnus-group-buffer) | ||
| 3293 | (setq method (gnus-info-method info)) | ||
| 3294 | (when (gnus-server-equal method "native") | ||
| 3295 | (setq method nil)) | ||
| 3296 | (save-excursion | 3573 | (save-excursion |
| 3297 | (set-buffer gnus-group-buffer) | 3574 | (set-buffer gnus-group-buffer) |
| 3298 | (if method | 3575 | (setq method (gnus-info-method info)) |
| 3299 | ;; It's a foreign group... | 3576 | (when (gnus-server-equal method "native") |
| 3300 | (gnus-group-make-group | 3577 | (setq method nil)) |
| 3301 | (gnus-group-real-name (gnus-info-group info)) | 3578 | (save-excursion |
| 3302 | (if (stringp method) method | 3579 | (set-buffer gnus-group-buffer) |
| 3303 | (prin1-to-string (car method))) | 3580 | (if method |
| 3304 | (and (consp method) | 3581 | ;; It's a foreign group... |
| 3305 | (nth 1 (gnus-info-method info)))) | 3582 | (gnus-group-make-group |
| 3306 | ;; It's a native group. | 3583 | (gnus-group-real-name (gnus-info-group info)) |
| 3307 | (gnus-group-make-group (gnus-info-group info)))) | 3584 | (if (stringp method) method |
| 3308 | (gnus-message 6 "Note: New group created") | 3585 | (prin1-to-string (car method))) |
| 3309 | (setq entry | 3586 | (and (consp method) |
| 3310 | (gnus-gethash (gnus-group-prefixed-name | 3587 | (nth 1 (gnus-info-method info)))) |
| 3311 | (gnus-group-real-name (gnus-info-group info)) | 3588 | ;; It's a native group. |
| 3312 | (or (gnus-info-method info) gnus-select-method)) | 3589 | (gnus-group-make-group (gnus-info-group info)))) |
| 3313 | gnus-newsrc-hashtb)))) | 3590 | (gnus-message 6 "Note: New group created") |
| 3314 | ;; Whether it was a new group or not, we now have the entry, so we | 3591 | (setq entry |
| 3315 | ;; can do the update. | 3592 | (gnus-gethash (gnus-group-prefixed-name |
| 3316 | (if entry | 3593 | (gnus-group-real-name (gnus-info-group info)) |
| 3317 | (progn | 3594 | (or (gnus-info-method info) gnus-select-method)) |
| 3318 | (setcar (nthcdr 2 entry) info) | 3595 | gnus-newsrc-hashtb)))) |
| 3319 | (when (and (not (eq (car entry) t)) | 3596 | ;; Whether it was a new group or not, we now have the entry, so we |
| 3320 | (gnus-active (gnus-info-group info))) | 3597 | ;; can do the update. |
| 3321 | (setcar entry (length (gnus-list-of-unread-articles (car info)))))) | 3598 | (if entry |
| 3322 | (error "No such group: %s" (gnus-info-group info))))) | 3599 | (progn |
| 3600 | (setcar (nthcdr 2 entry) info) | ||
| 3601 | (when (and (not (eq (car entry) t)) | ||
| 3602 | (gnus-active (gnus-info-group info))) | ||
| 3603 | (setcar entry (length (gnus-list-of-unread-articles (car info)))))) | ||
| 3604 | (error "No such group: %s" (gnus-info-group info)))))) | ||
| 3323 | 3605 | ||
| 3324 | (defun gnus-group-set-method-info (group select-method) | 3606 | (defun gnus-group-set-method-info (group select-method) |
| 3325 | (gnus-group-set-info select-method group 'method)) | 3607 | (gnus-group-set-info select-method group 'method)) |
| @@ -3329,7 +3611,7 @@ and the second element is the address." | |||
| 3329 | 3611 | ||
| 3330 | (defun gnus-add-marked-articles (group type articles &optional info force) | 3612 | (defun gnus-add-marked-articles (group type articles &optional info force) |
| 3331 | ;; Add ARTICLES of TYPE to the info of GROUP. | 3613 | ;; Add ARTICLES of TYPE to the info of GROUP. |
| 3332 | ;; If INFO is non-nil, use that info. If FORCE is non-nil, don't | 3614 | ;; If INFO is non-nil, use that info. If FORCE is non-nil, don't |
| 3333 | ;; add, but replace marked articles of TYPE with ARTICLES. | 3615 | ;; add, but replace marked articles of TYPE with ARTICLES. |
| 3334 | (let ((info (or info (gnus-get-info group))) | 3616 | (let ((info (or info (gnus-get-info group))) |
| 3335 | marked m) | 3617 | marked m) |
| @@ -3373,8 +3655,8 @@ or `gnus-group-catchup-group-hook'." | |||
| 3373 | (defun gnus-group-timestamp-delta (group) | 3655 | (defun gnus-group-timestamp-delta (group) |
| 3374 | "Return the offset in seconds from the timestamp for GROUP to the current time, as a floating point number." | 3656 | "Return the offset in seconds from the timestamp for GROUP to the current time, as a floating point number." |
| 3375 | (let* ((time (or (gnus-group-timestamp group) | 3657 | (let* ((time (or (gnus-group-timestamp group) |
| 3376 | (list 0 0))) | 3658 | (list 0 0))) |
| 3377 | (delta (gnus-time-minus (current-time) time))) | 3659 | (delta (subtract-time (current-time) time))) |
| 3378 | (+ (* (nth 0 delta) 65536.0) | 3660 | (+ (* (nth 0 delta) 65536.0) |
| 3379 | (nth 1 delta)))) | 3661 | (nth 1 delta)))) |
| 3380 | 3662 | ||
| @@ -3385,6 +3667,118 @@ or `gnus-group-catchup-group-hook'." | |||
| 3385 | "" | 3667 | "" |
| 3386 | (gnus-time-iso8601 time)))) | 3668 | (gnus-time-iso8601 time)))) |
| 3387 | 3669 | ||
| 3670 | (defun gnus-group-prepare-flat-list-dead-predicate | ||
| 3671 | (groups level mark predicate) | ||
| 3672 | (let (group) | ||
| 3673 | (if predicate | ||
| 3674 | ;; This loop is used when listing groups that match some | ||
| 3675 | ;; regexp. | ||
| 3676 | (while (setq group (pop groups)) | ||
| 3677 | (when (funcall predicate group) | ||
| 3678 | (gnus-add-text-properties | ||
| 3679 | (point) (prog1 (1+ (point)) | ||
| 3680 | (insert " " mark " *: " | ||
| 3681 | (gnus-group-name-decode group | ||
| 3682 | (gnus-group-name-charset | ||
| 3683 | nil group)) | ||
| 3684 | "\n")) | ||
| 3685 | (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb) | ||
| 3686 | 'gnus-unread t | ||
| 3687 | 'gnus-level level))))))) | ||
| 3688 | |||
| 3689 | (defun gnus-group-prepare-flat-predicate (level predicate &optional lowest | ||
| 3690 | dead-predicate) | ||
| 3691 | "List all newsgroups with unread articles of level LEVEL or lower. | ||
| 3692 | If LOWEST is non-nil, list all newsgroups of level LOWEST or higher. | ||
| 3693 | If PREDICATE, only list groups which PREDICATE returns non-nil. | ||
| 3694 | If DEAD-PREDICATE, list dead groups which DEAD-PREDICATE returns non-nil." | ||
| 3695 | (set-buffer gnus-group-buffer) | ||
| 3696 | (let ((buffer-read-only nil) | ||
| 3697 | (newsrc (cdr gnus-newsrc-alist)) | ||
| 3698 | (lowest (or lowest 1)) | ||
| 3699 | info clevel unread group params) | ||
| 3700 | (erase-buffer) | ||
| 3701 | ;; List living groups. | ||
| 3702 | (while newsrc | ||
| 3703 | (setq info (car newsrc) | ||
| 3704 | group (gnus-info-group info) | ||
| 3705 | params (gnus-info-params info) | ||
| 3706 | newsrc (cdr newsrc) | ||
| 3707 | unread (car (gnus-gethash group gnus-newsrc-hashtb))) | ||
| 3708 | (and unread ; This group might be unchecked | ||
| 3709 | (funcall predicate info) | ||
| 3710 | (<= (setq clevel (gnus-info-level info)) level) | ||
| 3711 | (>= clevel lowest) | ||
| 3712 | (gnus-group-insert-group-line | ||
| 3713 | group (gnus-info-level info) | ||
| 3714 | (gnus-info-marks info) unread (gnus-info-method info)))) | ||
| 3715 | |||
| 3716 | ;; List dead groups. | ||
| 3717 | (and (>= level gnus-level-zombie) (<= lowest gnus-level-zombie) | ||
| 3718 | (gnus-group-prepare-flat-list-dead-predicate | ||
| 3719 | (setq gnus-zombie-list (sort gnus-zombie-list 'string<)) | ||
| 3720 | gnus-level-zombie ?Z | ||
| 3721 | dead-predicate)) | ||
| 3722 | (and (>= level gnus-level-killed) (<= lowest gnus-level-killed) | ||
| 3723 | (gnus-group-prepare-flat-list-dead-predicate | ||
| 3724 | (setq gnus-killed-list (sort gnus-killed-list 'string<)) | ||
| 3725 | gnus-level-killed ?K dead-predicate)) | ||
| 3726 | |||
| 3727 | (gnus-group-set-mode-line) | ||
| 3728 | (setq gnus-group-list-mode (cons level t)) | ||
| 3729 | (gnus-run-hooks 'gnus-group-prepare-hook) | ||
| 3730 | t)) | ||
| 3731 | |||
| 3732 | (defun gnus-group-list-cached (level &optional lowest) | ||
| 3733 | "List all groups with cached articles. | ||
| 3734 | If the prefix LEVEL is non-nil, it should be a number that says which | ||
| 3735 | level to cut off listing groups. | ||
| 3736 | If LOWEST, don't list groups with level lower than LOWEST. | ||
| 3737 | |||
| 3738 | This command may read the active file." | ||
| 3739 | (interactive "P") | ||
| 3740 | (when level | ||
| 3741 | (setq level (prefix-numeric-value level))) | ||
| 3742 | (when (or (not level) (>= level gnus-level-zombie)) | ||
| 3743 | (gnus-cache-open)) | ||
| 3744 | (gnus-group-prepare-flat-predicate (or level gnus-level-subscribed) | ||
| 3745 | #'(lambda (info) | ||
| 3746 | (let ((marks (gnus-info-marks info))) | ||
| 3747 | (assq 'cache marks))) | ||
| 3748 | lowest | ||
| 3749 | #'(lambda (group) | ||
| 3750 | (or (gnus-gethash group | ||
| 3751 | gnus-cache-active-hashtb) | ||
| 3752 | ;; Cache active file might use "." | ||
| 3753 | ;; instead of ":". | ||
| 3754 | (gnus-gethash | ||
| 3755 | (mapconcat 'identity | ||
| 3756 | (split-string group ":") | ||
| 3757 | ".") | ||
| 3758 | gnus-cache-active-hashtb)))) | ||
| 3759 | (goto-char (point-min)) | ||
| 3760 | (gnus-group-position-point)) | ||
| 3761 | |||
| 3762 | (defun gnus-group-list-dormant (level &optional lowest) | ||
| 3763 | "List all groups with dormant articles. | ||
| 3764 | If the prefix LEVEL is non-nil, it should be a number that says which | ||
| 3765 | level to cut off listing groups. | ||
| 3766 | If LOWEST, don't list groups with level lower than LOWEST. | ||
| 3767 | |||
| 3768 | This command may read the active file." | ||
| 3769 | (interactive "P") | ||
| 3770 | (when level | ||
| 3771 | (setq level (prefix-numeric-value level))) | ||
| 3772 | (when (or (not level) (>= level gnus-level-zombie)) | ||
| 3773 | (gnus-cache-open)) | ||
| 3774 | (gnus-group-prepare-flat-predicate (or level gnus-level-subscribed) | ||
| 3775 | #'(lambda (info) | ||
| 3776 | (let ((marks (gnus-info-marks info))) | ||
| 3777 | (assq 'dormant marks))) | ||
| 3778 | lowest) | ||
| 3779 | (goto-char (point-min)) | ||
| 3780 | (gnus-group-position-point)) | ||
| 3781 | |||
| 3388 | (provide 'gnus-group) | 3782 | (provide 'gnus-group) |
| 3389 | 3783 | ||
| 3390 | ;;; gnus-group.el ends here | 3784 | ;;; gnus-group.el ends here |
diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el index 992eac52c4a..7f80f8ea049 100644 --- a/lisp/gnus/gnus-msg.el +++ b/lisp/gnus/gnus-msg.el | |||
| @@ -1,5 +1,6 @@ | |||
| 1 | ;;; gnus-msg.el --- mail and post interface for Gnus | 1 | ;;; gnus-msg.el --- mail and post interface for Gnus |
| 2 | ;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. | 2 | ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 |
| 3 | ;; Free Software Foundation, Inc. | ||
| 3 | 4 | ||
| 4 | ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> | 5 | ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> |
| 5 | ;; Lars Magne Ingebrigtsen <larsi@gnus.org> | 6 | ;; Lars Magne Ingebrigtsen <larsi@gnus.org> |
| @@ -28,26 +29,24 @@ | |||
| 28 | 29 | ||
| 29 | (eval-when-compile (require 'cl)) | 30 | (eval-when-compile (require 'cl)) |
| 30 | 31 | ||
| 31 | (eval-when-compile (require 'cl)) | ||
| 32 | |||
| 33 | (require 'gnus) | 32 | (require 'gnus) |
| 34 | (require 'gnus-ems) | 33 | (require 'gnus-ems) |
| 35 | (require 'message) | 34 | (require 'message) |
| 36 | (require 'gnus-art) | 35 | (require 'gnus-art) |
| 37 | 36 | ||
| 38 | (defcustom gnus-post-method nil | 37 | (defcustom gnus-post-method 'current |
| 39 | "*Preferred method for posting USENET news. | 38 | "*Preferred method for posting USENET news. |
| 40 | 39 | ||
| 41 | If this variable is `current', Gnus will use the \"current\" select | 40 | If this variable is `current', Gnus will use the \"current\" select |
| 42 | method when posting. If it is nil (which is the default), Gnus will | 41 | method when posting. If it is nil (which is the default), Gnus will |
| 43 | use the native posting method of the server. | 42 | use the native select method when posting. |
| 44 | 43 | ||
| 45 | This method will not be used in mail groups and the like, only in | 44 | This method will not be used in mail groups and the like, only in |
| 46 | \"real\" newsgroups. | 45 | \"real\" newsgroups. |
| 47 | 46 | ||
| 48 | If not nil nor `native', the value must be a valid method as discussed | 47 | 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 | 48 | 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 | 49 | methods. If that is the case, the user will be queried for what select |
| 51 | method to use when posting." | 50 | method to use when posting." |
| 52 | :group 'gnus-group-foreign | 51 | :group 'gnus-group-foreign |
| 53 | :type `(choice (const nil) | 52 | :type `(choice (const nil) |
| @@ -102,13 +101,37 @@ the second with the current group name.") | |||
| 102 | (defvar gnus-posting-styles nil | 101 | (defvar gnus-posting-styles nil |
| 103 | "*Alist of styles to use when posting.") | 102 | "*Alist of styles to use when posting.") |
| 104 | 103 | ||
| 105 | (defvar gnus-posting-style-alist | 104 | (defcustom gnus-group-posting-charset-alist |
| 106 | '((organization . message-user-organization) | 105 | '(("^\\(no\\|fr\\|dk\\)\\.[^,]*\\(,[ \t\n]*\\(no\\|fr\\|dk\\)\\.[^,]*\\)*$" iso-8859-1 (iso-8859-1)) |
| 107 | (signature . message-signature) | 106 | ("^\\(fido7\\|relcom\\)\\.[^,]*\\(,[ \t\n]*\\(fido7\\|relcom\\)\\.[^,]*\\)*$" koi8-r (koi8-r)) |
| 108 | (signature-file . message-signature-file) | 107 | (message-this-is-mail nil nil) |
| 109 | (address . user-mail-address) | 108 | (message-this-is-news nil t)) |
| 110 | (name . user-full-name)) | 109 | "Alist of regexps and permitted unencoded charsets for posting. |
| 111 | "*Mapping from style parameters to variables.") | 110 | Each element of the alist has the form (TEST HEADER BODY-LIST), where |
| 111 | TEST is either a regular expression matching the newsgroup header or a | ||
| 112 | variable to query, | ||
| 113 | HEADER is the charset which may be left unencoded in the header (nil | ||
| 114 | means encode all charsets), | ||
| 115 | BODY-LIST is a list of charsets which may be encoded using 8bit | ||
| 116 | content-transfer encoding in the body, or one of the special values | ||
| 117 | nil (always encode using quoted-printable) or t (always use 8bit). | ||
| 118 | |||
| 119 | Note that any value other than nil for HEADER infringes some RFCs, so | ||
| 120 | use this option with care." | ||
| 121 | :type '(repeat (list :tag "Permitted unencoded charsets" | ||
| 122 | (choice :tag "Where" | ||
| 123 | (regexp :tag "Group") | ||
| 124 | (const :tag "Mail message" :value message-this-is-mail) | ||
| 125 | (const :tag "News article" :value message-this-is-news)) | ||
| 126 | (choice :tag "Header" | ||
| 127 | (const :tag "None" nil) | ||
| 128 | (symbol :tag "Charset")) | ||
| 129 | (choice :tag "Body" | ||
| 130 | (const :tag "Any" :value t) | ||
| 131 | (const :tag "None" :value nil) | ||
| 132 | (repeat :tag "Charsets" | ||
| 133 | (symbol :tag "Charset"))))) | ||
| 134 | :group 'gnus-charset) | ||
| 112 | 135 | ||
| 113 | ;;; Internal variables. | 136 | ;;; Internal variables. |
| 114 | 137 | ||
| @@ -127,9 +150,10 @@ the second with the current group name.") | |||
| 127 | The buffer below is a mail buffer. When you press `C-c C-c', it will | 150 | The buffer below is a mail buffer. When you press `C-c C-c', it will |
| 128 | be sent to the Gnus Bug Exterminators. | 151 | be sent to the Gnus Bug Exterminators. |
| 129 | 152 | ||
| 130 | At the bottom of the buffer you'll see lots of variable settings. | 153 | The thing near the bottom of the buffer is how the environment |
| 131 | Please do not delete those. They will tell the Bug People what your | 154 | settings will be included in the mail. Please do not delete that. |
| 132 | environment is, so that it will be easier to locate the bugs. | 155 | They will tell the Bug People what your environment is, so that it |
| 156 | will be easier to locate the bugs. | ||
| 133 | 157 | ||
| 134 | If you have found a bug that makes Emacs go \"beep\", set | 158 | If you have found a bug that makes Emacs go \"beep\", set |
| 135 | debug-on-error to t (`M-x set-variable RET debug-on-error RET t RET') | 159 | debug-on-error to t (`M-x set-variable RET debug-on-error RET t RET') |
| @@ -159,6 +183,7 @@ Thank you for your help in stamping out bugs. | |||
| 159 | "c" gnus-summary-cancel-article | 183 | "c" gnus-summary-cancel-article |
| 160 | "s" gnus-summary-supersede-article | 184 | "s" gnus-summary-supersede-article |
| 161 | "r" gnus-summary-reply | 185 | "r" gnus-summary-reply |
| 186 | "y" gnus-summary-yank-message | ||
| 162 | "R" gnus-summary-reply-with-original | 187 | "R" gnus-summary-reply-with-original |
| 163 | "w" gnus-summary-wide-reply | 188 | "w" gnus-summary-wide-reply |
| 164 | "W" gnus-summary-wide-reply-with-original | 189 | "W" gnus-summary-wide-reply-with-original |
| @@ -177,6 +202,20 @@ Thank you for your help in stamping out bugs. | |||
| 177 | ;; "c" gnus-summary-send-draft | 202 | ;; "c" gnus-summary-send-draft |
| 178 | "r" gnus-summary-resend-message) | 203 | "r" gnus-summary-resend-message) |
| 179 | 204 | ||
| 205 | ;;;###autoload | ||
| 206 | (defun gnus-msg-mail (&rest args) | ||
| 207 | "Start editing a mail message to be sent. | ||
| 208 | Like `message-mail', but with Gnus paraphernalia, particularly the | ||
| 209 | the Gcc: header for archiving purposes." | ||
| 210 | (interactive) | ||
| 211 | (gnus-setup-message 'message | ||
| 212 | (apply 'message-mail args))) | ||
| 213 | |||
| 214 | ;;;###autoload | ||
| 215 | (define-mail-user-agent 'gnus-user-agent | ||
| 216 | 'gnus-msg-mail 'message-send-and-exit | ||
| 217 | 'message-kill-buffer 'message-send-hook) | ||
| 218 | |||
| 180 | ;;; Internal functions. | 219 | ;;; Internal functions. |
| 181 | 220 | ||
| 182 | (defvar gnus-article-reply nil) | 221 | (defvar gnus-article-reply nil) |
| @@ -191,7 +230,9 @@ Thank you for your help in stamping out bugs. | |||
| 191 | (,group gnus-newsgroup-name) | 230 | (,group gnus-newsgroup-name) |
| 192 | (message-header-setup-hook | 231 | (message-header-setup-hook |
| 193 | (copy-sequence message-header-setup-hook)) | 232 | (copy-sequence message-header-setup-hook)) |
| 233 | (mbl mml-buffer-list) | ||
| 194 | (message-mode-hook (copy-sequence message-mode-hook))) | 234 | (message-mode-hook (copy-sequence message-mode-hook))) |
| 235 | (setq mml-buffer-list nil) | ||
| 195 | (add-hook 'message-header-setup-hook 'gnus-inews-insert-gcc) | 236 | (add-hook 'message-header-setup-hook 'gnus-inews-insert-gcc) |
| 196 | (add-hook 'message-header-setup-hook 'gnus-inews-insert-archive-gcc) | 237 | (add-hook 'message-header-setup-hook 'gnus-inews-insert-archive-gcc) |
| 197 | (add-hook 'message-mode-hook 'gnus-configure-posting-styles) | 238 | (add-hook 'message-mode-hook 'gnus-configure-posting-styles) |
| @@ -202,12 +243,37 @@ Thank you for your help in stamping out bugs. | |||
| 202 | (setq gnus-message-buffer (current-buffer)) | 243 | (setq gnus-message-buffer (current-buffer)) |
| 203 | (set (make-local-variable 'gnus-message-group-art) | 244 | (set (make-local-variable 'gnus-message-group-art) |
| 204 | (cons ,group ,article)) | 245 | (cons ,group ,article)) |
| 205 | (make-local-variable 'gnus-newsgroup-name) | 246 | (set (make-local-variable 'gnus-newsgroup-name) ,group) |
| 206 | (gnus-run-hooks 'gnus-message-setup-hook)) | 247 | (gnus-run-hooks 'gnus-message-setup-hook) |
| 248 | (if (eq major-mode 'message-mode) | ||
| 249 | ;; Make mml-buffer-list local. | ||
| 250 | ;; Restore global mml-buffer-list value as mbl. | ||
| 251 | ;; What a hack! -- Shenghuo | ||
| 252 | (let ((mml-buffer-list mml-buffer-list)) | ||
| 253 | (setq mml-buffer-list mbl) | ||
| 254 | (make-local-variable 'mml-buffer-list) | ||
| 255 | (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t)) | ||
| 256 | (mml-destroy-buffers) | ||
| 257 | (setq mml-buffer-list mbl))) | ||
| 207 | (gnus-add-buffer) | 258 | (gnus-add-buffer) |
| 208 | (gnus-configure-windows ,config t) | 259 | (gnus-configure-windows ,config t) |
| 209 | (set-buffer-modified-p nil)))) | 260 | (set-buffer-modified-p nil)))) |
| 210 | 261 | ||
| 262 | (defun gnus-setup-posting-charset (group) | ||
| 263 | (let ((alist gnus-group-posting-charset-alist) | ||
| 264 | (group (or group "")) | ||
| 265 | elem) | ||
| 266 | (when group | ||
| 267 | (catch 'found | ||
| 268 | (while (setq elem (pop alist)) | ||
| 269 | (when (or (and (stringp (car elem)) | ||
| 270 | (string-match (car elem) group)) | ||
| 271 | (and (gnus-functionp (car elem)) | ||
| 272 | (funcall (car elem) group)) | ||
| 273 | (and (symbolp (car elem)) | ||
| 274 | (symbol-value (car elem)))) | ||
| 275 | (throw 'found (cons (cadr elem) (caddr elem))))))))) | ||
| 276 | |||
| 211 | (defun gnus-inews-add-send-actions (winconf buffer article) | 277 | (defun gnus-inews-add-send-actions (winconf buffer article) |
| 212 | (make-local-hook 'message-sent-hook) | 278 | (make-local-hook 'message-sent-hook) |
| 213 | (add-hook 'message-sent-hook 'gnus-inews-do-gcc nil t) | 279 | (add-hook 'message-sent-hook 'gnus-inews-do-gcc nil t) |
| @@ -230,11 +296,29 @@ Thank you for your help in stamping out bugs. | |||
| 230 | 296 | ||
| 231 | ;;; Post news commands of Gnus group mode and summary mode | 297 | ;;; Post news commands of Gnus group mode and summary mode |
| 232 | 298 | ||
| 233 | (defun gnus-group-mail () | 299 | (defun gnus-group-mail (&optional arg) |
| 234 | "Start composing a mail." | 300 | "Start composing a mail. |
| 235 | (interactive) | 301 | If ARG, use the group under the point to find a posting style. |
| 236 | (gnus-setup-message 'message | 302 | If ARG is 1, prompt for a group name to find the posting style." |
| 237 | (message-mail))) | 303 | (interactive "P") |
| 304 | ;; We can't `let' gnus-newsgroup-name here, since that leads | ||
| 305 | ;; to local variables leaking. | ||
| 306 | (let ((group gnus-newsgroup-name) | ||
| 307 | (buffer (current-buffer))) | ||
| 308 | (unwind-protect | ||
| 309 | (progn | ||
| 310 | (setq gnus-newsgroup-name | ||
| 311 | (if arg | ||
| 312 | (if (= 1 (prefix-numeric-value arg)) | ||
| 313 | (completing-read "Use posting style of group: " | ||
| 314 | gnus-active-hashtb nil | ||
| 315 | (gnus-read-active-file-p)) | ||
| 316 | (gnus-group-group-name)) | ||
| 317 | "")) | ||
| 318 | (gnus-setup-message 'message (message-mail))) | ||
| 319 | (save-excursion | ||
| 320 | (set-buffer buffer) | ||
| 321 | (setq gnus-newsgroup-name group))))) | ||
| 238 | 322 | ||
| 239 | (defun gnus-group-post-news (&optional arg) | 323 | (defun gnus-group-post-news (&optional arg) |
| 240 | "Start composing a news message. | 324 | "Start composing a news message. |
| @@ -355,7 +439,9 @@ header line with the old Message-ID." | |||
| 355 | ;; if ARTICLE-BUFFER is nil, gnus-article-buffer is used | 439 | ;; if ARTICLE-BUFFER is nil, gnus-article-buffer is used |
| 356 | ;; this buffer should be passed to all mail/news reply/post routines. | 440 | ;; this buffer should be passed to all mail/news reply/post routines. |
| 357 | (setq gnus-article-copy (gnus-get-buffer-create " *gnus article copy*")) | 441 | (setq gnus-article-copy (gnus-get-buffer-create " *gnus article copy*")) |
| 358 | (buffer-disable-undo gnus-article-copy) | 442 | (save-excursion |
| 443 | (set-buffer gnus-article-copy) | ||
| 444 | (mm-enable-multibyte)) | ||
| 359 | (let ((article-buffer (or article-buffer gnus-article-buffer)) | 445 | (let ((article-buffer (or article-buffer gnus-article-buffer)) |
| 360 | end beg) | 446 | end beg) |
| 361 | (if (not (and (get-buffer article-buffer) | 447 | (if (not (and (get-buffer article-buffer) |
| @@ -374,7 +460,7 @@ header line with the old Message-ID." | |||
| 374 | (gnus-remove-text-with-property 'gnus-next) | 460 | (gnus-remove-text-with-property 'gnus-next) |
| 375 | (insert | 461 | (insert |
| 376 | (prog1 | 462 | (prog1 |
| 377 | (format "%s" (buffer-string)) | 463 | (buffer-substring-no-properties (point-min) (point-max)) |
| 378 | (erase-buffer))) | 464 | (erase-buffer))) |
| 379 | ;; Find the original headers. | 465 | ;; Find the original headers. |
| 380 | (set-buffer gnus-original-article-buffer) | 466 | (set-buffer gnus-original-article-buffer) |
| @@ -386,10 +472,10 @@ header line with the old Message-ID." | |||
| 386 | ;; Delete the headers from the displayed articles. | 472 | ;; Delete the headers from the displayed articles. |
| 387 | (set-buffer gnus-article-copy) | 473 | (set-buffer gnus-article-copy) |
| 388 | (delete-region (goto-char (point-min)) | 474 | (delete-region (goto-char (point-min)) |
| 389 | (or (search-forward "\n\n" nil t) (point))) | 475 | (or (search-forward "\n\n" nil t) (point-max))) |
| 390 | ;; Insert the original article headers. | 476 | ;; Insert the original article headers. |
| 391 | (insert-buffer-substring gnus-original-article-buffer beg end) | 477 | (insert-buffer-substring gnus-original-article-buffer beg end) |
| 392 | (gnus-article-decode-rfc1522))) | 478 | (article-decode-encoded-words))) |
| 393 | gnus-article-copy))) | 479 | gnus-article-copy))) |
| 394 | 480 | ||
| 395 | (defun gnus-post-news (post &optional group header article-buffer yank subject | 481 | (defun gnus-post-news (post &optional group header article-buffer yank subject |
| @@ -402,6 +488,7 @@ header line with the old Message-ID." | |||
| 402 | (article-buffer 'reply) | 488 | (article-buffer 'reply) |
| 403 | (t 'message)) | 489 | (t 'message)) |
| 404 | (let* ((group (or group gnus-newsgroup-name)) | 490 | (let* ((group (or group gnus-newsgroup-name)) |
| 491 | (charset (gnus-group-name-charset nil group)) | ||
| 405 | (pgroup group) | 492 | (pgroup group) |
| 406 | to-address to-group mailing-list to-list | 493 | to-address to-group mailing-list to-list |
| 407 | newsgroup-p) | 494 | newsgroup-p) |
| @@ -412,7 +499,8 @@ header line with the old Message-ID." | |||
| 412 | newsgroup-p (gnus-group-find-parameter group 'newsgroup) | 499 | newsgroup-p (gnus-group-find-parameter group 'newsgroup) |
| 413 | mailing-list (when gnus-mailing-list-groups | 500 | mailing-list (when gnus-mailing-list-groups |
| 414 | (string-match gnus-mailing-list-groups group)) | 501 | (string-match gnus-mailing-list-groups group)) |
| 415 | group (gnus-group-real-name group))) | 502 | group (gnus-group-name-decode (gnus-group-real-name group) |
| 503 | charset))) | ||
| 416 | (if (or (and to-group | 504 | (if (or (and to-group |
| 417 | (gnus-news-group-p to-group)) | 505 | (gnus-news-group-p to-group)) |
| 418 | newsgroup-p | 506 | newsgroup-p |
| @@ -464,7 +552,7 @@ If SILENT, don't prompt the user." | |||
| 464 | ;; the default method. | 552 | ;; the default method. |
| 465 | ((null group-method) | 553 | ((null group-method) |
| 466 | (or (and (null (eq gnus-post-method 'active)) gnus-post-method) | 554 | (or (and (null (eq gnus-post-method 'active)) gnus-post-method) |
| 467 | gnus-select-method message-post-method)) | 555 | gnus-select-method message-post-method)) |
| 468 | ;; We want the inverse of the default | 556 | ;; We want the inverse of the default |
| 469 | ((and arg (not (eq arg 0))) | 557 | ((and arg (not (eq arg 0))) |
| 470 | (if (eq gnus-post-method 'active) | 558 | (if (eq gnus-post-method 'active) |
| @@ -485,14 +573,16 @@ If SILENT, don't prompt the user." | |||
| 485 | (list gnus-post-method))) | 573 | (list gnus-post-method))) |
| 486 | gnus-secondary-select-methods | 574 | gnus-secondary-select-methods |
| 487 | (mapcar 'cdr gnus-server-alist) | 575 | (mapcar 'cdr gnus-server-alist) |
| 576 | (mapcar 'car gnus-opened-servers) | ||
| 488 | (list gnus-select-method) | 577 | (list gnus-select-method) |
| 489 | (list group-method))) | 578 | (list group-method))) |
| 490 | method-alist post-methods method) | 579 | method-alist post-methods method) |
| 491 | ;; Weed out all mail methods. | 580 | ;; Weed out all mail methods. |
| 492 | (while methods | 581 | (while methods |
| 493 | (setq method (gnus-server-get-method "" (pop methods))) | 582 | (setq method (gnus-server-get-method "" (pop methods))) |
| 494 | (when (or (gnus-method-option-p method 'post) | 583 | (when (and (or (gnus-method-option-p method 'post) |
| 495 | (gnus-method-option-p method 'post-mail)) | 584 | (gnus-method-option-p method 'post-mail)) |
| 585 | (not (member method post-methods))) | ||
| 496 | (push method post-methods))) | 586 | (push method post-methods))) |
| 497 | ;; Create a name-method alist. | 587 | ;; Create a name-method alist. |
| 498 | (setq method-alist | 588 | (setq method-alist |
| @@ -515,8 +605,9 @@ If SILENT, don't prompt the user." | |||
| 515 | ;; Override normal method. | 605 | ;; Override normal method. |
| 516 | ((and (eq gnus-post-method 'current) | 606 | ((and (eq gnus-post-method 'current) |
| 517 | (not (eq (car group-method) 'nndraft)) | 607 | (not (eq (car group-method) 'nndraft)) |
| 608 | (gnus-get-function group-method 'request-post t) | ||
| 518 | (not arg)) | 609 | (not arg)) |
| 519 | group-method) | 610 | group-method) |
| 520 | ((and gnus-post-method | 611 | ((and gnus-post-method |
| 521 | (not (eq gnus-post-method 'current))) | 612 | (not (eq gnus-post-method 'current))) |
| 522 | gnus-post-method) | 613 | gnus-post-method) |
| @@ -525,69 +616,32 @@ If SILENT, don't prompt the user." | |||
| 525 | 616 | ||
| 526 | 617 | ||
| 527 | 618 | ||
| 528 | ;; Dummy to avoid byte-compile warning. | 619 | ;; Dummies to avoid byte-compile warning. |
| 529 | (defvar nnspool-rejected-article-hook) | 620 | (defvar nnspool-rejected-article-hook) |
| 530 | (defvar xemacs-codename) | 621 | (defvar xemacs-codename) |
| 531 | 622 | ||
| 532 | ;;; Since the X-Newsreader/X-Mailer are ``vanity'' headers, they might | ||
| 533 | ;;; as well include the Emacs version as well. | ||
| 534 | ;;; The following function works with later GNU Emacs, and XEmacs. | ||
| 535 | (defun gnus-extended-version () | 623 | (defun gnus-extended-version () |
| 536 | "Stringified Gnus version and Emacs version." | 624 | "Stringified Gnus version and Emacs version." |
| 537 | (interactive) | 625 | (interactive) |
| 538 | (concat | 626 | (concat |
| 539 | gnus-version | 627 | "Gnus/" (prin1-to-string (gnus-continuum-version gnus-version) t) |
| 540 | "/" | 628 | " (" gnus-version ")" |
| 629 | " " | ||
| 541 | (cond | 630 | (cond |
| 542 | ((string-match "^\\([0-9]+\\.[0-9]+\\)\\.[.0-9]+$" emacs-version) | 631 | ((string-match "^\\(\\([.0-9]+\\)*\\)\\.[0-9]+$" emacs-version) |
| 543 | (concat "Emacs " (substring emacs-version | 632 | (concat "Emacs/" (match-string 1 emacs-version))) |
| 544 | (match-beginning 1) | ||
| 545 | (match-end 1)))) | ||
| 546 | ((string-match "\\([A-Z]*[Mm][Aa][Cc][Ss]\\)[^(]*\\(\\((beta.*)\\|'\\)\\)?" | 633 | ((string-match "\\([A-Z]*[Mm][Aa][Cc][Ss]\\)[^(]*\\(\\((beta.*)\\|'\\)\\)?" |
| 547 | emacs-version) | 634 | emacs-version) |
| 548 | (concat (substring emacs-version | 635 | (concat (match-string 1 emacs-version) |
| 549 | (match-beginning 1) | 636 | (format "/%d.%d" emacs-major-version emacs-minor-version) |
| 550 | (match-end 1)) | ||
| 551 | (format " %d.%d" emacs-major-version emacs-minor-version) | ||
| 552 | (if (match-beginning 3) | 637 | (if (match-beginning 3) |
| 553 | (substring emacs-version | 638 | (match-string 3 emacs-version) |
| 554 | (match-beginning 3) | ||
| 555 | (match-end 3)) | ||
| 556 | "") | 639 | "") |
| 557 | (if (boundp 'xemacs-codename) | 640 | (if (boundp 'xemacs-codename) |
| 558 | (concat " - \"" xemacs-codename "\"")))) | 641 | (concat " (" xemacs-codename ")") |
| 642 | ""))) | ||
| 559 | (t emacs-version)))) | 643 | (t emacs-version)))) |
| 560 | 644 | ||
| 561 | ;; Written by "Mr. Per Persson" <pp@gnu.org>. | ||
| 562 | (defun gnus-inews-insert-mime-headers () | ||
| 563 | "Insert MIME headers. | ||
| 564 | Assumes ISO-Latin-1 is used iff 8-bit characters are present." | ||
| 565 | (goto-char (point-min)) | ||
| 566 | (let ((mail-header-separator | ||
| 567 | (progn | ||
| 568 | (goto-char (point-min)) | ||
| 569 | (if (and (search-forward (concat "\n" mail-header-separator "\n") | ||
| 570 | nil t) | ||
| 571 | (not (search-backward "\n\n" nil t))) | ||
| 572 | mail-header-separator | ||
| 573 | "")))) | ||
| 574 | (or (mail-position-on-field "Mime-Version") | ||
| 575 | (insert "1.0") | ||
| 576 | (cond ((save-restriction | ||
| 577 | (widen) | ||
| 578 | (goto-char (point-min)) | ||
| 579 | (re-search-forward "[^\000-\177]" nil t)) | ||
| 580 | (or (mail-position-on-field "Content-Type") | ||
| 581 | (insert "text/plain; charset=ISO-8859-1")) | ||
| 582 | (or (mail-position-on-field "Content-Transfer-Encoding") | ||
| 583 | (insert "8bit"))) | ||
| 584 | (t (or (mail-position-on-field "Content-Type") | ||
| 585 | (insert "text/plain; charset=US-ASCII")) | ||
| 586 | (or (mail-position-on-field "Content-Transfer-Encoding") | ||
| 587 | (insert "7bit"))))))) | ||
| 588 | |||
| 589 | (custom-add-option 'message-header-hook 'gnus-inews-insert-mime-headers) | ||
| 590 | |||
| 591 | 645 | ||
| 592 | ;;; | 646 | ;;; |
| 593 | ;;; Gnus Mail Functions | 647 | ;;; Gnus Mail Functions |
| @@ -610,6 +664,10 @@ automatically." | |||
| 610 | (gnus-summary-select-article) | 664 | (gnus-summary-select-article) |
| 611 | (set-buffer (gnus-copy-article-buffer)) | 665 | (set-buffer (gnus-copy-article-buffer)) |
| 612 | (gnus-msg-treat-broken-reply-to) | 666 | (gnus-msg-treat-broken-reply-to) |
| 667 | (save-restriction | ||
| 668 | (message-narrow-to-head) | ||
| 669 | (goto-char (point-max))) | ||
| 670 | (mml-quote-region (point) (point-max)) | ||
| 613 | (message-reply nil wide) | 671 | (message-reply nil wide) |
| 614 | (when yank | 672 | (when yank |
| 615 | (gnus-inews-yank-articles yank))))) | 673 | (gnus-inews-yank-articles yank))))) |
| @@ -635,16 +693,50 @@ The original article will be yanked." | |||
| 635 | (interactive "P") | 693 | (interactive "P") |
| 636 | (gnus-summary-reply-with-original n t)) | 694 | (gnus-summary-reply-with-original n t)) |
| 637 | 695 | ||
| 638 | (defun gnus-summary-mail-forward (&optional full-headers post) | 696 | (defun gnus-summary-mail-forward (&optional arg post) |
| 639 | "Forward the current message to another user. | 697 | "Forward the current message to another user. |
| 640 | If FULL-HEADERS (the prefix), include full headers when forwarding." | 698 | If ARG is nil, see `message-forward-as-mime' and `message-forward-show-mml'; |
| 699 | if ARG is 1, decode the message and forward directly inline; | ||
| 700 | if ARG is 2, foward message as an rfc822 MIME section; | ||
| 701 | if ARG is 3, decode message and forward as an rfc822 MIME section; | ||
| 702 | if ARG is 4, foward message directly inline; | ||
| 703 | otherwise, use flipped `message-forward-as-mime'. | ||
| 704 | If POST, post instead of mail." | ||
| 641 | (interactive "P") | 705 | (interactive "P") |
| 642 | (gnus-setup-message 'forward | 706 | (let ((message-forward-as-mime message-forward-as-mime) |
| 643 | (gnus-summary-select-article) | 707 | (message-forward-show-mml message-forward-show-mml)) |
| 644 | (set-buffer gnus-original-article-buffer) | 708 | (cond |
| 645 | (let ((message-included-forward-headers | 709 | ((null arg)) |
| 646 | (if full-headers "" message-included-forward-headers))) | 710 | ((eq arg 1) (setq message-forward-as-mime nil |
| 647 | (message-forward post)))) | 711 | message-forward-show-mml t)) |
| 712 | ((eq arg 2) (setq message-forward-as-mime t | ||
| 713 | message-forward-show-mml nil)) | ||
| 714 | ((eq arg 3) (setq message-forward-as-mime t | ||
| 715 | message-forward-show-mml t)) | ||
| 716 | ((eq arg 4) (setq message-forward-as-mime nil | ||
| 717 | message-forward-show-mml nil)) | ||
| 718 | (t (setq message-forward-as-mime (not message-forward-as-mime)))) | ||
| 719 | (gnus-setup-message 'forward | ||
| 720 | (gnus-summary-select-article) | ||
| 721 | (let ((mail-parse-charset gnus-newsgroup-charset) | ||
| 722 | (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets) | ||
| 723 | text) | ||
| 724 | (save-excursion | ||
| 725 | (set-buffer gnus-original-article-buffer) | ||
| 726 | (setq text (buffer-string))) | ||
| 727 | (set-buffer | ||
| 728 | (gnus-get-buffer-create | ||
| 729 | (generate-new-buffer-name " *Gnus forward*"))) | ||
| 730 | (erase-buffer) | ||
| 731 | (unless message-forward-show-mml | ||
| 732 | (mm-disable-multibyte)) | ||
| 733 | (insert text) | ||
| 734 | (goto-char (point-min)) | ||
| 735 | (when (looking-at "From ") | ||
| 736 | (replace-match "X-From-Line: ") ) | ||
| 737 | (when message-forward-show-mml | ||
| 738 | (mime-to-mml)) | ||
| 739 | (message-forward post))))) | ||
| 648 | 740 | ||
| 649 | (defun gnus-summary-resend-message (address n) | 741 | (defun gnus-summary-resend-message (address n) |
| 650 | "Resend the current article to ADDRESS." | 742 | "Resend the current article to ADDRESS." |
| @@ -657,11 +749,11 @@ If FULL-HEADERS (the prefix), include full headers when forwarding." | |||
| 657 | (set-buffer gnus-original-article-buffer) | 749 | (set-buffer gnus-original-article-buffer) |
| 658 | (message-resend address))))) | 750 | (message-resend address))))) |
| 659 | 751 | ||
| 660 | (defun gnus-summary-post-forward (&optional full-headers) | 752 | (defun gnus-summary-post-forward (&optional arg) |
| 661 | "Forward the current article to a newsgroup. | 753 | "Forward the current article to a newsgroup. |
| 662 | If FULL-HEADERS (the prefix), include full headers when forwarding." | 754 | See `gnus-summary-mail-forward' for ARG." |
| 663 | (interactive "P") | 755 | (interactive "P") |
| 664 | (gnus-summary-mail-forward full-headers t)) | 756 | (gnus-summary-mail-forward arg t)) |
| 665 | 757 | ||
| 666 | (defvar gnus-nastygram-message | 758 | (defvar gnus-nastygram-message |
| 667 | "The following article was inappropriately posted to %s.\n\n" | 759 | "The following article was inappropriately posted to %s.\n\n" |
| @@ -694,7 +786,8 @@ The current group name will be inserted at \"%s\".") | |||
| 694 | (gnus-summary-select-article) | 786 | (gnus-summary-select-article) |
| 695 | (set-buffer gnus-original-article-buffer) | 787 | (set-buffer gnus-original-article-buffer) |
| 696 | (if (and (<= (length (message-tokenize-header | 788 | (if (and (<= (length (message-tokenize-header |
| 697 | (setq newsgroups (mail-fetch-field "newsgroups")) | 789 | (setq newsgroups |
| 790 | (mail-fetch-field "newsgroups")) | ||
| 698 | ", ")) | 791 | ", ")) |
| 699 | 1) | 792 | 1) |
| 700 | (or (not (setq followup-to (mail-fetch-field "followup-to"))) | 793 | (or (not (setq followup-to (mail-fetch-field "followup-to"))) |
| @@ -833,7 +926,12 @@ If YANK is non-nil, include the original article." | |||
| 833 | (stringp nntp-server-type)) | 926 | (stringp nntp-server-type)) |
| 834 | (insert nntp-server-type)) | 927 | (insert nntp-server-type)) |
| 835 | (insert "\n\n\n\n\n") | 928 | (insert "\n\n\n\n\n") |
| 836 | (gnus-debug) | 929 | (let (text) |
| 930 | (save-excursion | ||
| 931 | (set-buffer (gnus-get-buffer-create " *gnus environment info*")) | ||
| 932 | (gnus-debug) | ||
| 933 | (setq text (buffer-string))) | ||
| 934 | (insert "<#part type=application/x-emacs-lisp disposition=inline description=\"User settings\">\n" text "\n<#/part>")) | ||
| 837 | (goto-char (point-min)) | 935 | (goto-char (point-min)) |
| 838 | (search-forward "Subject: " nil t) | 936 | (search-forward "Subject: " nil t) |
| 839 | (message ""))) | 937 | (message ""))) |
| @@ -842,6 +940,19 @@ If YANK is non-nil, include the original article." | |||
| 842 | (when (get-buffer "*Gnus Help Bug*") | 940 | (when (get-buffer "*Gnus Help Bug*") |
| 843 | (kill-buffer "*Gnus Help Bug*"))) | 941 | (kill-buffer "*Gnus Help Bug*"))) |
| 844 | 942 | ||
| 943 | (defun gnus-summary-yank-message (buffer n) | ||
| 944 | "Yank the current article into a composed message." | ||
| 945 | (interactive | ||
| 946 | (list (completing-read "Buffer: " (mapcar 'list (message-buffers)) nil t) | ||
| 947 | current-prefix-arg)) | ||
| 948 | (gnus-summary-iterate n | ||
| 949 | (let ((gnus-display-mime-function nil) | ||
| 950 | (gnus-inhibit-treatment t)) | ||
| 951 | (gnus-summary-select-article)) | ||
| 952 | (save-excursion | ||
| 953 | (set-buffer buffer) | ||
| 954 | (message-yank-buffer gnus-article-buffer)))) | ||
| 955 | |||
| 845 | (defun gnus-debug () | 956 | (defun gnus-debug () |
| 846 | "Attempts to go through the Gnus source file and report what variables have been changed. | 957 | "Attempts to go through the Gnus source file and report what variables have been changed. |
| 847 | The source file has to be in the Emacs load path." | 958 | The source file has to be in the Emacs load path." |
| @@ -857,7 +968,6 @@ The source file has to be in the Emacs load path." | |||
| 857 | ;; Go through all the files looking for non-default values for variables. | 968 | ;; Go through all the files looking for non-default values for variables. |
| 858 | (save-excursion | 969 | (save-excursion |
| 859 | (set-buffer (gnus-get-buffer-create " *gnus bug info*")) | 970 | (set-buffer (gnus-get-buffer-create " *gnus bug info*")) |
| 860 | (buffer-disable-undo (current-buffer)) | ||
| 861 | (while files | 971 | (while files |
| 862 | (erase-buffer) | 972 | (erase-buffer) |
| 863 | (when (and (setq file (locate-library (pop files))) | 973 | (when (and (setq file (locate-library (pop files))) |
| @@ -940,7 +1050,8 @@ this is a reply." | |||
| 940 | (when gcc | 1050 | (when gcc |
| 941 | (message-remove-header "gcc") | 1051 | (message-remove-header "gcc") |
| 942 | (widen) | 1052 | (widen) |
| 943 | (setq groups (message-tokenize-header gcc " ,")) | 1053 | (setq groups (message-unquote-tokens |
| 1054 | (message-tokenize-header gcc " ,"))) | ||
| 944 | ;; Copy the article over to some group(s). | 1055 | ;; Copy the article over to some group(s). |
| 945 | (while (setq group (pop groups)) | 1056 | (while (setq group (pop groups)) |
| 946 | (gnus-check-server | 1057 | (gnus-check-server |
| @@ -964,12 +1075,20 @@ this is a reply." | |||
| 964 | (save-excursion | 1075 | (save-excursion |
| 965 | (nnheader-set-temp-buffer " *acc*") | 1076 | (nnheader-set-temp-buffer " *acc*") |
| 966 | (insert-buffer-substring cur) | 1077 | (insert-buffer-substring cur) |
| 1078 | (message-encode-message-body) | ||
| 1079 | (save-restriction | ||
| 1080 | (message-narrow-to-headers) | ||
| 1081 | (let ((mail-parse-charset message-default-charset) | ||
| 1082 | (rfc2047-header-encoding-alist | ||
| 1083 | (cons '("Newsgroups" . default) | ||
| 1084 | rfc2047-header-encoding-alist))) | ||
| 1085 | (mail-encode-encoded-word-buffer))) | ||
| 967 | (goto-char (point-min)) | 1086 | (goto-char (point-min)) |
| 968 | (when (re-search-forward | 1087 | (when (re-search-forward |
| 969 | (concat "^" (regexp-quote mail-header-separator) "$") | 1088 | (concat "^" (regexp-quote mail-header-separator) "$") |
| 970 | nil t) | 1089 | nil t) |
| 971 | (replace-match "" t t )) | 1090 | (replace-match "" t t )) |
| 972 | (unless (gnus-request-accept-article group method t) | 1091 | (unless (gnus-request-accept-article group method t t) |
| 973 | (gnus-message 1 "Couldn't store article in group %s: %s" | 1092 | (gnus-message 1 "Couldn't store article in group %s: %s" |
| 974 | group (gnus-status-message method)) | 1093 | group (gnus-status-message method)) |
| 975 | (sit-for 2)) | 1094 | (sit-for 2)) |
| @@ -998,9 +1117,10 @@ this is a reply." | |||
| 998 | (group (or group gnus-newsgroup-name "")) | 1117 | (group (or group gnus-newsgroup-name "")) |
| 999 | (gcc-self-val | 1118 | (gcc-self-val |
| 1000 | (and gnus-newsgroup-name | 1119 | (and gnus-newsgroup-name |
| 1120 | (not (equal gnus-newsgroup-name "")) | ||
| 1001 | (gnus-group-find-parameter | 1121 | (gnus-group-find-parameter |
| 1002 | gnus-newsgroup-name 'gcc-self))) | 1122 | gnus-newsgroup-name 'gcc-self))) |
| 1003 | result | 1123 | result |
| 1004 | (groups | 1124 | (groups |
| 1005 | (cond | 1125 | (cond |
| 1006 | ((null gnus-message-archive-method) | 1126 | ((null gnus-message-archive-method) |
| @@ -1068,86 +1188,131 @@ this is a reply." | |||
| 1068 | 1188 | ||
| 1069 | ;;; Posting styles. | 1189 | ;;; Posting styles. |
| 1070 | 1190 | ||
| 1071 | (defvar gnus-message-style-insertions nil) | ||
| 1072 | |||
| 1073 | (defun gnus-configure-posting-styles () | 1191 | (defun gnus-configure-posting-styles () |
| 1074 | "Configure posting styles according to `gnus-posting-styles'." | 1192 | "Configure posting styles according to `gnus-posting-styles'." |
| 1075 | (unless gnus-inhibit-posting-styles | 1193 | (unless gnus-inhibit-posting-styles |
| 1076 | (let ((styles gnus-posting-styles) | 1194 | (let ((group (or gnus-newsgroup-name "")) |
| 1077 | (gnus-newsgroup-name (or gnus-newsgroup-name "")) | 1195 | (styles gnus-posting-styles) |
| 1078 | style match variable attribute value value-value) | 1196 | style match variable attribute value v results |
| 1079 | (make-local-variable 'gnus-message-style-insertions) | 1197 | filep name address element) |
| 1198 | ;; If the group has a posting-style parameter, add it at the end with a | ||
| 1199 | ;; regexp matching everything, to be sure it takes precedence over all | ||
| 1200 | ;; the others. | ||
| 1201 | (when gnus-newsgroup-name | ||
| 1202 | (let ((tmp-style (gnus-group-find-parameter group 'posting-style t))) | ||
| 1203 | (when tmp-style | ||
| 1204 | (setq styles (append styles (list (cons ".*" tmp-style))))))) | ||
| 1080 | ;; Go through all styles and look for matches. | 1205 | ;; Go through all styles and look for matches. |
| 1081 | (while styles | 1206 | (dolist (style styles) |
| 1082 | (setq style (pop styles) | 1207 | (setq match (pop style)) |
| 1083 | match (pop style)) | 1208 | (goto-char (point-min)) |
| 1084 | (when (cond ((stringp match) | 1209 | (when (cond |
| 1085 | ;; Regexp string match on the group name. | 1210 | ((stringp match) |
| 1086 | (string-match match gnus-newsgroup-name)) | 1211 | ;; Regexp string match on the group name. |
| 1087 | ((or (symbolp match) | 1212 | (string-match match group)) |
| 1088 | (gnus-functionp match)) | 1213 | ((eq match 'header) |
| 1089 | (cond ((gnus-functionp match) | 1214 | (let ((header (message-fetch-field (pop style)))) |
| 1090 | ;; Function to be called. | 1215 | (and header |
| 1091 | (funcall match)) | 1216 | (string-match (pop style) header)))) |
| 1092 | ((boundp match) | 1217 | ((or (symbolp match) |
| 1093 | ;; Variable to be checked. | 1218 | (gnus-functionp match)) |
| 1094 | (symbol-value match)))) | 1219 | (cond |
| 1095 | ((listp match) | 1220 | ((gnus-functionp match) |
| 1096 | ;; This is a form to be evaled. | 1221 | ;; Function to be called. |
| 1097 | (eval match))) | 1222 | (funcall match)) |
| 1223 | ((boundp match) | ||
| 1224 | ;; Variable to be checked. | ||
| 1225 | (symbol-value match)))) | ||
| 1226 | ((listp match) | ||
| 1227 | ;; This is a form to be evaled. | ||
| 1228 | (eval match))) | ||
| 1098 | ;; We have a match, so we set the variables. | 1229 | ;; We have a match, so we set the variables. |
| 1099 | (while style | 1230 | (dolist (attribute style) |
| 1100 | (setq attribute (pop style) | 1231 | (setq element (pop attribute) |
| 1101 | value (cadr attribute) | 1232 | variable nil |
| 1102 | variable nil) | 1233 | filep nil) |
| 1103 | ;; We find the variable that is to be modified. | 1234 | (setq value |
| 1104 | (if (and (not (stringp (car attribute))) | 1235 | (cond |
| 1105 | (not (eq 'body (car attribute))) | 1236 | ((eq (car attribute) :file) |
| 1106 | (not (setq variable | 1237 | (setq filep t) |
| 1107 | (cdr (assq (car attribute) | 1238 | (cadr attribute)) |
| 1108 | gnus-posting-style-alist))))) | 1239 | ((eq (car attribute) :value) |
| 1109 | (message "Couldn't find attribute %s" (car attribute)) | 1240 | (cadr attribute)) |
| 1110 | ;; We get the value. | 1241 | (t |
| 1111 | (setq value-value | 1242 | (car attribute)))) |
| 1112 | (cond ((stringp value) | 1243 | ;; We get the value. |
| 1113 | value) | 1244 | (setq v |
| 1114 | ((or (symbolp value) | 1245 | (cond |
| 1115 | (gnus-functionp value)) | 1246 | ((stringp value) |
| 1116 | (cond ((gnus-functionp value) | 1247 | value) |
| 1117 | (funcall value)) | 1248 | ((or (symbolp value) |
| 1118 | ((boundp value) | 1249 | (gnus-functionp value)) |
| 1119 | (symbol-value value)))) | 1250 | (cond ((gnus-functionp value) |
| 1120 | ((listp value) | 1251 | (funcall value)) |
| 1121 | (eval value)))) | 1252 | ((boundp value) |
| 1122 | (if variable | 1253 | (symbol-value value)))) |
| 1123 | ;; This is an ordinary variable. | 1254 | ((listp value) |
| 1124 | (set (make-local-variable variable) value-value) | 1255 | (eval value)))) |
| 1125 | ;; This is either a body or a header to be inserted in the | 1256 | ;; Translate obsolescent value. |
| 1126 | ;; message. | 1257 | (when (eq element 'signature-file) |
| 1127 | (when value-value | 1258 | (setq element 'signature |
| 1128 | (let ((attr (car attribute))) | 1259 | filep t)) |
| 1129 | (make-local-variable 'message-setup-hook) | 1260 | ;; Get the contents of file elems. |
| 1130 | (if (eq 'body attr) | 1261 | (when (and filep v) |
| 1131 | (add-hook 'message-setup-hook | 1262 | (setq v (with-temp-buffer |
| 1132 | `(lambda () | 1263 | (insert-file-contents v) |
| 1133 | (save-excursion | 1264 | (buffer-string)))) |
| 1134 | (message-goto-body) | 1265 | (setq results (delq (assoc element results) results)) |
| 1135 | (insert ,value-value)))) | 1266 | (push (cons element v) results)))) |
| 1136 | (add-hook 'message-setup-hook | 1267 | ;; Now we have all the styles, so we insert them. |
| 1137 | 'gnus-message-insert-stylings) | 1268 | (setq name (assq 'name results) |
| 1138 | (push (cons (if (stringp attr) attr | 1269 | address (assq 'address results)) |
| 1139 | (symbol-name attr)) | 1270 | (setq results (delq name (delq address results))) |
| 1140 | value-value) | 1271 | (make-local-variable 'message-setup-hook) |
| 1141 | gnus-message-style-insertions)))))))))))) | 1272 | (dolist (result results) |
| 1142 | 1273 | (add-hook 'message-setup-hook | |
| 1143 | (defun gnus-message-insert-stylings () | 1274 | (cond |
| 1144 | (let (val) | 1275 | ((eq 'eval (car result)) |
| 1145 | (save-excursion | 1276 | 'ignore) |
| 1146 | (message-goto-eoh) | 1277 | ((eq 'body (car result)) |
| 1147 | (while (setq val (pop gnus-message-style-insertions)) | 1278 | `(lambda () |
| 1148 | (when (cdr val) | 1279 | (save-excursion |
| 1149 | (insert (car val) ": " (cdr val) "\n")) | 1280 | (message-goto-body) |
| 1150 | (gnus-pull (car val) gnus-message-style-insertions))))) | 1281 | (insert ,(cdr result))))) |
| 1282 | ((eq 'signature (car result)) | ||
| 1283 | (set (make-local-variable 'message-signature) nil) | ||
| 1284 | (set (make-local-variable 'message-signature-file) nil) | ||
| 1285 | (if (not (cdr result)) | ||
| 1286 | 'ignore | ||
| 1287 | `(lambda () | ||
| 1288 | (save-excursion | ||
| 1289 | (let ((message-signature ,(cdr result))) | ||
| 1290 | (when message-signature | ||
| 1291 | (message-insert-signature))))))) | ||
| 1292 | (t | ||
| 1293 | (let ((header | ||
| 1294 | (if (symbolp (car result)) | ||
| 1295 | (capitalize (symbol-name (car result))) | ||
| 1296 | (car result)))) | ||
| 1297 | `(lambda () | ||
| 1298 | (save-excursion | ||
| 1299 | (message-remove-header ,header) | ||
| 1300 | (let ((value ,(cdr result))) | ||
| 1301 | (when value | ||
| 1302 | (message-goto-eoh) | ||
| 1303 | (insert ,header ": " value "\n")))))))))) | ||
| 1304 | (when (or name address) | ||
| 1305 | (add-hook 'message-setup-hook | ||
| 1306 | `(lambda () | ||
| 1307 | (set (make-local-variable 'user-mail-address) | ||
| 1308 | ,(or (cdr address) user-mail-address)) | ||
| 1309 | (let ((user-full-name ,(or (cdr name) (user-full-name))) | ||
| 1310 | (user-mail-address | ||
| 1311 | ,(or (cdr address) user-mail-address))) | ||
| 1312 | (save-excursion | ||
| 1313 | (message-remove-header "From") | ||
| 1314 | (message-goto-eoh) | ||
| 1315 | (insert "From: " (message-make-from) "\n"))))))))) | ||
| 1151 | 1316 | ||
| 1152 | ;;; Allow redefinition of functions. | 1317 | ;;; Allow redefinition of functions. |
| 1153 | 1318 | ||
diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index 45658018139..999e3b039fe 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el | |||
| @@ -1,5 +1,6 @@ | |||
| 1 | ;;; gnus-sum.el --- summary mode commands for Gnus | 1 | ;;; gnus-sum.el --- summary mode commands for Gnus |
| 2 | ;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. | 2 | ;; Copyright (C) 1996, 1997, 1998, 1999, 2000 |
| 3 | ;; Free Software Foundation, Inc. | ||
| 3 | 4 | ||
| 4 | ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> | 5 | ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
| 5 | ;; Keywords: news | 6 | ;; Keywords: news |
| @@ -27,8 +28,6 @@ | |||
| 27 | 28 | ||
| 28 | (eval-when-compile (require 'cl)) | 29 | (eval-when-compile (require 'cl)) |
| 29 | 30 | ||
| 30 | (eval-when-compile (require 'cl)) | ||
| 31 | |||
| 32 | (require 'gnus) | 31 | (require 'gnus) |
| 33 | (require 'gnus-group) | 32 | (require 'gnus-group) |
| 34 | (require 'gnus-spec) | 33 | (require 'gnus-spec) |
| @@ -36,6 +35,7 @@ | |||
| 36 | (require 'gnus-int) | 35 | (require 'gnus-int) |
| 37 | (require 'gnus-undo) | 36 | (require 'gnus-undo) |
| 38 | (require 'gnus-util) | 37 | (require 'gnus-util) |
| 38 | (require 'mm-decode) | ||
| 39 | (autoload 'gnus-summary-limit-include-cached "gnus-cache" nil t) | 39 | (autoload 'gnus-summary-limit-include-cached "gnus-cache" nil t) |
| 40 | 40 | ||
| 41 | (defcustom gnus-kill-summary-on-exit t | 41 | (defcustom gnus-kill-summary-on-exit t |
| @@ -169,10 +169,15 @@ This variable will only be used if the value of | |||
| 169 | :type 'string) | 169 | :type 'string) |
| 170 | 170 | ||
| 171 | (defcustom gnus-summary-goto-unread t | 171 | (defcustom gnus-summary-goto-unread t |
| 172 | "*If t, marking commands will go to the next unread article. | 172 | "*If t, many commands will go to the next unread article. |
| 173 | If `never', commands that usually go to the next unread article, will | 173 | This applies to marking commands as well as other commands that |
| 174 | go to the next article, whether it is read or not. | 174 | \"naturally\" select the next article, like, for instance, `SPC' at |
| 175 | If nil, only the marking commands will go to the next (un)read article." | 175 | the end of an article. |
| 176 | |||
| 177 | If nil, the marking commands do NOT go to the next unread article | ||
| 178 | (they go to the next article instead). If `never', commands that | ||
| 179 | usually go to the next unread article, will go to the next article, | ||
| 180 | whether it is read or not." | ||
| 176 | :group 'gnus-summary-marks | 181 | :group 'gnus-summary-marks |
| 177 | :link '(custom-manual "(gnus)Setting Marks") | 182 | :link '(custom-manual "(gnus)Setting Marks") |
| 178 | :type '(choice (const :tag "off" nil) | 183 | :type '(choice (const :tag "off" nil) |
| @@ -254,8 +259,12 @@ equal will be included." | |||
| 254 | (defcustom gnus-auto-select-first t | 259 | (defcustom gnus-auto-select-first t |
| 255 | "*If nil, don't select the first unread article when entering a group. | 260 | "*If nil, don't select the first unread article when entering a group. |
| 256 | If this variable is `best', select the highest-scored unread article | 261 | If this variable is `best', select the highest-scored unread article |
| 257 | in the group. If neither nil nor `best', select the first unread | 262 | in the group. If t, select the first unread article. |
| 258 | article. | 263 | |
| 264 | This variable can also be a function to place point on a likely | ||
| 265 | subject line. Useful values include `gnus-summary-first-unread-subject', | ||
| 266 | `gnus-summary-first-unread-article' and | ||
| 267 | `gnus-summary-best-unread-article'. | ||
| 259 | 268 | ||
| 260 | If you want to prevent automatic selection of the first unread article | 269 | If you want to prevent automatic selection of the first unread article |
| 261 | in some newsgroups, set the variable to nil in | 270 | in some newsgroups, set the variable to nil in |
| @@ -263,7 +272,10 @@ in some newsgroups, set the variable to nil in | |||
| 263 | :group 'gnus-group-select | 272 | :group 'gnus-group-select |
| 264 | :type '(choice (const :tag "none" nil) | 273 | :type '(choice (const :tag "none" nil) |
| 265 | (const best) | 274 | (const best) |
| 266 | (sexp :menu-tag "first" t))) | 275 | (sexp :menu-tag "first" t) |
| 276 | (function-item gnus-summary-first-unread-subject) | ||
| 277 | (function-item gnus-summary-first-unread-article) | ||
| 278 | (function-item gnus-summary-best-unread-article))) | ||
| 267 | 279 | ||
| 268 | (defcustom gnus-auto-select-next t | 280 | (defcustom gnus-auto-select-next t |
| 269 | "*If non-nil, offer to go to the next group from the end of the previous. | 281 | "*If non-nil, offer to go to the next group from the end of the previous. |
| @@ -304,6 +316,7 @@ and non-`vertical', do both horizontal and vertical recentering." | |||
| 304 | :group 'gnus-summary-maneuvering | 316 | :group 'gnus-summary-maneuvering |
| 305 | :type '(choice (const :tag "none" nil) | 317 | :type '(choice (const :tag "none" nil) |
| 306 | (const vertical) | 318 | (const vertical) |
| 319 | (integer :tag "height") | ||
| 307 | (sexp :menu-tag "both" t))) | 320 | (sexp :menu-tag "both" t))) |
| 308 | 321 | ||
| 309 | (defcustom gnus-show-all-headers nil | 322 | (defcustom gnus-show-all-headers nil |
| @@ -330,13 +343,6 @@ variable." | |||
| 330 | :group 'gnus-article-various | 343 | :group 'gnus-article-various |
| 331 | :type 'boolean) | 344 | :type 'boolean) |
| 332 | 345 | ||
| 333 | (defcustom gnus-show-mime nil | ||
| 334 | "*If non-nil, do mime processing of articles. | ||
| 335 | The articles will simply be fed to the function given by | ||
| 336 | `gnus-show-mime-method'." | ||
| 337 | :group 'gnus-article-mime | ||
| 338 | :type 'boolean) | ||
| 339 | |||
| 340 | (defcustom gnus-move-split-methods nil | 346 | (defcustom gnus-move-split-methods nil |
| 341 | "*Variable used to suggest where articles are to be moved to. | 347 | "*Variable used to suggest where articles are to be moved to. |
| 342 | It uses the same syntax as the `gnus-split-methods' variable." | 348 | It uses the same syntax as the `gnus-split-methods' variable." |
| @@ -345,7 +351,7 @@ It uses the same syntax as the `gnus-split-methods' variable." | |||
| 345 | (cons :value ("" "") regexp (repeat string)) | 351 | (cons :value ("" "") regexp (repeat string)) |
| 346 | (sexp :value nil)))) | 352 | (sexp :value nil)))) |
| 347 | 353 | ||
| 348 | (defcustom gnus-unread-mark ? ;space | 354 | (defcustom gnus-unread-mark ? ;Whitespace |
| 349 | "*Mark used for unread articles." | 355 | "*Mark used for unread articles." |
| 350 | :group 'gnus-summary-marks | 356 | :group 'gnus-summary-marks |
| 351 | :type 'character) | 357 | :type 'character) |
| @@ -460,7 +466,7 @@ It uses the same syntax as the `gnus-split-methods' variable." | |||
| 460 | :group 'gnus-summary-marks | 466 | :group 'gnus-summary-marks |
| 461 | :type 'character) | 467 | :type 'character) |
| 462 | 468 | ||
| 463 | (defcustom gnus-empty-thread-mark ? ;space | 469 | (defcustom gnus-empty-thread-mark ? ;Whitespace |
| 464 | "*There is no thread under the article." | 470 | "*There is no thread under the article." |
| 465 | :group 'gnus-summary-marks | 471 | :group 'gnus-summary-marks |
| 466 | :type 'character) | 472 | :type 'character) |
| @@ -475,6 +481,19 @@ It uses the same syntax as the `gnus-split-methods' variable." | |||
| 475 | :group 'gnus-extract-view | 481 | :group 'gnus-extract-view |
| 476 | :type 'boolean) | 482 | :type 'boolean) |
| 477 | 483 | ||
| 484 | (defcustom gnus-auto-expirable-marks | ||
| 485 | (list gnus-killed-mark gnus-del-mark gnus-catchup-mark | ||
| 486 | gnus-low-score-mark gnus-ancient-mark gnus-read-mark | ||
| 487 | gnus-souped-mark gnus-duplicate-mark) | ||
| 488 | "*The list of marks converted into expiration if a group is auto-expirable." | ||
| 489 | :group 'gnus-summary | ||
| 490 | :type '(repeat character)) | ||
| 491 | |||
| 492 | (defcustom gnus-inhibit-user-auto-expire t | ||
| 493 | "*If non-nil, user marking commands will not mark an article as expirable, even if the group has auto-expire turned on." | ||
| 494 | :group 'gnus-summary | ||
| 495 | :type 'boolean) | ||
| 496 | |||
| 478 | (defcustom gnus-view-pseudos nil | 497 | (defcustom gnus-view-pseudos nil |
| 479 | "*If `automatic', pseudo-articles will be viewed automatically. | 498 | "*If `automatic', pseudo-articles will be viewed automatically. |
| 480 | If `not-confirm', pseudos will be viewed automatically, and the user | 499 | If `not-confirm', pseudos will be viewed automatically, and the user |
| @@ -506,7 +525,7 @@ with some simple extensions. | |||
| 506 | :group 'gnus-threading | 525 | :group 'gnus-threading |
| 507 | :type 'string) | 526 | :type 'string) |
| 508 | 527 | ||
| 509 | (defcustom gnus-summary-mode-line-format "Gnus: %%b [%A] %Z" | 528 | (defcustom gnus-summary-mode-line-format "Gnus: %g [%A] %Z" |
| 510 | "*The format specification for the summary mode line. | 529 | "*The format specification for the summary mode line. |
| 511 | It works along the same lines as a normal formatting string, | 530 | It works along the same lines as a normal formatting string, |
| 512 | with some simple extensions: | 531 | with some simple extensions: |
| @@ -529,6 +548,15 @@ with some simple extensions: | |||
| 529 | :group 'gnus-summary-format | 548 | :group 'gnus-summary-format |
| 530 | :type 'string) | 549 | :type 'string) |
| 531 | 550 | ||
| 551 | (defcustom gnus-list-identifiers nil | ||
| 552 | "Regexp that matches list identifiers to be removed from subject. | ||
| 553 | This can also be a list of regexps." | ||
| 554 | :group 'gnus-summary-format | ||
| 555 | :group 'gnus-article-hiding | ||
| 556 | :type '(choice (const :tag "none" nil) | ||
| 557 | (regexp :value ".*") | ||
| 558 | (repeat :value (".*") regexp))) | ||
| 559 | |||
| 532 | (defcustom gnus-summary-mark-below 0 | 560 | (defcustom gnus-summary-mark-below 0 |
| 533 | "*Mark all articles with a score below this variable as read. | 561 | "*Mark all articles with a score below this variable as read. |
| 534 | This variable is local to each summary buffer and usually set by the | 562 | This variable is local to each summary buffer and usually set by the |
| @@ -593,7 +621,7 @@ See `gnus-thread-score-function' for en explanation of what a | |||
| 593 | \"thread score\" is. | 621 | \"thread score\" is. |
| 594 | 622 | ||
| 595 | This variable is local to the summary buffers." | 623 | This variable is local to the summary buffers." |
| 596 | :group 'gnus-treading | 624 | :group 'gnus-threading |
| 597 | :group 'gnus-score-default | 625 | :group 'gnus-score-default |
| 598 | :type '(choice (const :tag "off" nil) | 626 | :type '(choice (const :tag "off" nil) |
| 599 | integer)) | 627 | integer)) |
| @@ -665,38 +693,14 @@ is not run if `gnus-visual' is nil." | |||
| 665 | :group 'gnus-summary-visual | 693 | :group 'gnus-summary-visual |
| 666 | :type 'hook) | 694 | :type 'hook) |
| 667 | 695 | ||
| 668 | (defcustom gnus-structured-field-decoder | 696 | (defcustom gnus-parse-headers-hook nil |
| 669 | (if (and (featurep 'mule) | ||
| 670 | (boundp 'enable-multibyte-characters)) | ||
| 671 | (lambda (string) | ||
| 672 | (if (and enable-multibyte-characters gnus-mule-coding-system) | ||
| 673 | (decode-coding-string string gnus-mule-coding-system) | ||
| 674 | string)) | ||
| 675 | 'identity) | ||
| 676 | "Function to decode non-ASCII characters in structured field for summary." | ||
| 677 | :group 'gnus-various | ||
| 678 | :type 'function) | ||
| 679 | |||
| 680 | (defcustom gnus-unstructured-field-decoder | ||
| 681 | (if (and (featurep 'mule) | ||
| 682 | (boundp 'enable-multibyte-characters)) | ||
| 683 | (lambda (string) | ||
| 684 | (if (and enable-multibyte-characters gnus-mule-coding-system) | ||
| 685 | (decode-coding-string string gnus-mule-coding-system) | ||
| 686 | string)) | ||
| 687 | 'identity) | ||
| 688 | "Function to decode non-ASCII characters in unstructured field for summary." | ||
| 689 | :group 'gnus-various | ||
| 690 | :type 'function) | ||
| 691 | |||
| 692 | (defcustom gnus-parse-headers-hook | ||
| 693 | (list 'gnus-hack-decode-rfc1522 'gnus-decode-rfc1522) | ||
| 694 | "*A hook called before parsing the headers." | 697 | "*A hook called before parsing the headers." |
| 695 | :group 'gnus-various | 698 | :group 'gnus-various |
| 696 | :type 'hook) | 699 | :type 'hook) |
| 697 | 700 | ||
| 698 | (defcustom gnus-exit-group-hook nil | 701 | (defcustom gnus-exit-group-hook nil |
| 699 | "*A hook called when exiting (not quitting) summary mode." | 702 | "*A hook called when exiting summary mode. |
| 703 | This hook is not called from the non-updating exit commands like `Q'." | ||
| 700 | :group 'gnus-various | 704 | :group 'gnus-various |
| 701 | :type 'hook) | 705 | :type 'hook) |
| 702 | 706 | ||
| @@ -795,10 +799,107 @@ mark: The articles mark." | |||
| 795 | The function is called with one parameter, the article header vector, | 799 | The function is called with one parameter, the article header vector, |
| 796 | which it may alter in any way.") | 800 | which it may alter in any way.") |
| 797 | 801 | ||
| 802 | (defvar gnus-decode-encoded-word-function 'mail-decode-encoded-word-string | ||
| 803 | "Variable that says which function should be used to decode a string with encoded words.") | ||
| 804 | |||
| 805 | (defcustom gnus-extra-headers nil | ||
| 806 | "*Extra headers to parse." | ||
| 807 | :group 'gnus-summary | ||
| 808 | :type '(repeat symbol)) | ||
| 809 | |||
| 810 | (defcustom gnus-ignored-from-addresses | ||
| 811 | (and user-mail-address (regexp-quote user-mail-address)) | ||
| 812 | "*Regexp of From headers that may be suppressed in favor of To headers." | ||
| 813 | :group 'gnus-summary | ||
| 814 | :type 'regexp) | ||
| 815 | |||
| 816 | (defcustom gnus-group-charset-alist | ||
| 817 | '(("^hk\\>\\|^tw\\>\\|\\<big5\\>" cn-big5) | ||
| 818 | ("^cn\\>\\|\\<chinese\\>" cn-gb-2312) | ||
| 819 | ("^fj\\>\\|^japan\\>" iso-2022-jp-2) | ||
| 820 | ("^tnn\\>\\|^pin\\>\\|^sci.lang.japan" iso-2022-7bit) | ||
| 821 | ("^relcom\\>" koi8-r) | ||
| 822 | ("^fido7\\>" koi8-r) | ||
| 823 | ("^\\(cz\\|hun\\|pl\\|sk\\|hr\\)\\>" iso-8859-2) | ||
| 824 | ("^israel\\>" iso-8859-1) | ||
| 825 | ("^han\\>" euc-kr) | ||
| 826 | ("^alt.chinese.text.big5\\>" chinese-big5) | ||
| 827 | ("^soc.culture.vietnamese\\>" vietnamese-viqr) | ||
| 828 | ("^\\(comp\\|rec\\|alt\\|sci\\|soc\\|news\\|gnu\\|bofh\\)\\>" iso-8859-1) | ||
| 829 | (".*" iso-8859-1)) | ||
| 830 | "Alist of regexps (to match group names) and default charsets to be used when reading." | ||
| 831 | :type '(repeat (list (regexp :tag "Group") | ||
| 832 | (symbol :tag "Charset"))) | ||
| 833 | :group 'gnus-charset) | ||
| 834 | |||
| 835 | (defcustom gnus-newsgroup-ignored-charsets '(unknown-8bit x-unknown) | ||
| 836 | "List of charsets that should be ignored. | ||
| 837 | When these charsets are used in the \"charset\" parameter, the | ||
| 838 | default charset will be used instead." | ||
| 839 | :type '(repeat symbol) | ||
| 840 | :group 'gnus-charset) | ||
| 841 | |||
| 842 | (defcustom gnus-group-ignored-charsets-alist | ||
| 843 | '(("alt\\.chinese\\.text" iso-8859-1)) | ||
| 844 | "Alist of regexps (to match group names) and charsets that should be ignored. | ||
| 845 | When these charsets are used in the \"charset\" parameter, the | ||
| 846 | default charset will be used instead." | ||
| 847 | :type '(repeat (cons (regexp :tag "Group") | ||
| 848 | (repeat symbol))) | ||
| 849 | :group 'gnus-charset) | ||
| 850 | |||
| 851 | (defcustom gnus-group-highlight-words-alist nil | ||
| 852 | "Alist of group regexps and highlight regexps. | ||
| 853 | This variable uses the same syntax as `gnus-emphasis-alist'." | ||
| 854 | :type '(repeat (cons (regexp :tag "Group") | ||
| 855 | (repeat (list (regexp :tag "Highlight regexp") | ||
| 856 | (number :tag "Group for entire word" 0) | ||
| 857 | (number :tag "Group for displayed part" 0) | ||
| 858 | (symbol :tag "Face" | ||
| 859 | gnus-emphasis-highlight-words))))) | ||
| 860 | :group 'gnus-summary-visual) | ||
| 861 | |||
| 862 | (defcustom gnus-summary-show-article-charset-alist | ||
| 863 | nil | ||
| 864 | "Alist of number and charset. | ||
| 865 | The article will be shown with the charset corresponding to the | ||
| 866 | numbered argument. | ||
| 867 | For example: ((1 . cn-gb-2312) (2 . big5))." | ||
| 868 | :type '(repeat (cons (number :tag "Argument" 1) | ||
| 869 | (symbol :tag "Charset"))) | ||
| 870 | :group 'gnus-charset) | ||
| 871 | |||
| 872 | (defcustom gnus-preserve-marks t | ||
| 873 | "Whether marks are preserved when moving, copying and respooling messages." | ||
| 874 | :type 'boolean | ||
| 875 | :group 'gnus-summary-marks) | ||
| 876 | |||
| 877 | (defcustom gnus-alter-articles-to-read-function nil | ||
| 878 | "Function to be called to alter the list of articles to be selected." | ||
| 879 | :type 'function | ||
| 880 | :group 'gnus-summary) | ||
| 881 | |||
| 882 | (defcustom gnus-orphan-score nil | ||
| 883 | "*All orphans get this score added. Set in the score file." | ||
| 884 | :group 'gnus-score-default | ||
| 885 | :type '(choice (const nil) | ||
| 886 | integer)) | ||
| 887 | |||
| 888 | (defcustom gnus-summary-save-parts-default-mime "image/.*" | ||
| 889 | "*A regexp to match MIME parts when saving multiple parts of a message | ||
| 890 | with gnus-summary-save-parts (X m). This regexp will be used by default | ||
| 891 | when prompting the user for which type of files to save." | ||
| 892 | :group 'gnus-summary | ||
| 893 | :type 'regexp) | ||
| 894 | |||
| 895 | |||
| 798 | ;;; Internal variables | 896 | ;;; Internal variables |
| 799 | 897 | ||
| 898 | (defvar gnus-article-mime-handles nil) | ||
| 899 | (defvar gnus-article-decoded-p nil) | ||
| 800 | (defvar gnus-scores-exclude-files nil) | 900 | (defvar gnus-scores-exclude-files nil) |
| 801 | (defvar gnus-page-broken nil) | 901 | (defvar gnus-page-broken nil) |
| 902 | (defvar gnus-inhibit-mime-unbuttonizing nil) | ||
| 802 | 903 | ||
| 803 | (defvar gnus-original-article nil) | 904 | (defvar gnus-original-article nil) |
| 804 | (defvar gnus-article-internal-prepare-hook nil) | 905 | (defvar gnus-article-internal-prepare-hook nil) |
| @@ -806,6 +907,11 @@ which it may alter in any way.") | |||
| 806 | 907 | ||
| 807 | (defvar gnus-thread-indent-array nil) | 908 | (defvar gnus-thread-indent-array nil) |
| 808 | (defvar gnus-thread-indent-array-level gnus-thread-indent-level) | 909 | (defvar gnus-thread-indent-array-level gnus-thread-indent-level) |
| 910 | (defvar gnus-sort-gathered-threads-function 'gnus-thread-sort-by-number | ||
| 911 | "Function called to sort the articles within a thread after it has been gathered together.") | ||
| 912 | |||
| 913 | (defvar gnus-summary-save-parts-type-history nil) | ||
| 914 | (defvar gnus-summary-save-parts-last-directory nil) | ||
| 809 | 915 | ||
| 810 | ;; Avoid highlighting in kill files. | 916 | ;; Avoid highlighting in kill files. |
| 811 | (defvar gnus-summary-inhibit-highlight nil) | 917 | (defvar gnus-summary-inhibit-highlight nil) |
| @@ -853,6 +959,7 @@ which it may alter in any way.") | |||
| 853 | (?l (bbb-grouplens-score gnus-tmp-header) ?s) | 959 | (?l (bbb-grouplens-score gnus-tmp-header) ?s) |
| 854 | (?V (gnus-thread-total-score (and (boundp 'thread) (car thread))) ?d) | 960 | (?V (gnus-thread-total-score (and (boundp 'thread) (car thread))) ?d) |
| 855 | (?U gnus-tmp-unread ?c) | 961 | (?U gnus-tmp-unread ?c) |
| 962 | (?f (gnus-summary-from-or-to-or-newsgroups gnus-tmp-header) ?s) | ||
| 856 | (?t (gnus-summary-number-of-articles-in-thread | 963 | (?t (gnus-summary-number-of-articles-in-thread |
| 857 | (and (boundp 'thread) (car thread)) gnus-tmp-level) | 964 | (and (boundp 'thread) (car thread)) gnus-tmp-level) |
| 858 | ?d) | 965 | ?d) |
| @@ -861,9 +968,9 @@ which it may alter in any way.") | |||
| 861 | ?c) | 968 | ?c) |
| 862 | (?u gnus-tmp-user-defined ?s) | 969 | (?u gnus-tmp-user-defined ?s) |
| 863 | (?P (gnus-pick-line-number) ?d)) | 970 | (?P (gnus-pick-line-number) ?d)) |
| 864 | "An alist of format specifications that can appear in summary lines, | 971 | "An alist of format specifications that can appear in summary lines. |
| 865 | and what variables they correspond with, along with the type of the | 972 | These are paired with what variables they correspond with, along with |
| 866 | variable (string, integer, character, etc).") | 973 | the type of the variable (string, integer, character, etc).") |
| 867 | 974 | ||
| 868 | (defvar gnus-summary-dummy-line-format-alist | 975 | (defvar gnus-summary-dummy-line-format-alist |
| 869 | `((?S gnus-tmp-subject ?s) | 976 | `((?S gnus-tmp-subject ?s) |
| @@ -979,6 +1086,9 @@ variable (string, integer, character, etc).") | |||
| 979 | (defvar gnus-have-all-headers nil) | 1086 | (defvar gnus-have-all-headers nil) |
| 980 | (defvar gnus-last-article nil) | 1087 | (defvar gnus-last-article nil) |
| 981 | (defvar gnus-newsgroup-history nil) | 1088 | (defvar gnus-newsgroup-history nil) |
| 1089 | (defvar gnus-newsgroup-charset nil) | ||
| 1090 | (defvar gnus-newsgroup-ephemeral-charset nil) | ||
| 1091 | (defvar gnus-newsgroup-ephemeral-ignored-charsets nil) | ||
| 982 | 1092 | ||
| 983 | (defconst gnus-summary-local-variables | 1093 | (defconst gnus-summary-local-variables |
| 984 | '(gnus-newsgroup-name | 1094 | '(gnus-newsgroup-name |
| @@ -1000,8 +1110,10 @@ variable (string, integer, character, etc).") | |||
| 1000 | gnus-newsgroup-dependencies gnus-newsgroup-selected-overlay | 1110 | gnus-newsgroup-dependencies gnus-newsgroup-selected-overlay |
| 1001 | gnus-newsgroup-scored gnus-newsgroup-kill-headers | 1111 | gnus-newsgroup-scored gnus-newsgroup-kill-headers |
| 1002 | gnus-thread-expunge-below | 1112 | gnus-thread-expunge-below |
| 1003 | gnus-score-alist gnus-current-score-file gnus-summary-expunge-below | 1113 | gnus-score-alist gnus-current-score-file |
| 1114 | (gnus-summary-expunge-below . global) | ||
| 1004 | (gnus-summary-mark-below . global) | 1115 | (gnus-summary-mark-below . global) |
| 1116 | (gnus-orphan-score . global) | ||
| 1005 | gnus-newsgroup-active gnus-scores-exclude-files | 1117 | gnus-newsgroup-active gnus-scores-exclude-files |
| 1006 | gnus-newsgroup-history gnus-newsgroup-ancient | 1118 | gnus-newsgroup-history gnus-newsgroup-ancient |
| 1007 | gnus-newsgroup-sparse gnus-newsgroup-process-stack | 1119 | gnus-newsgroup-sparse gnus-newsgroup-process-stack |
| @@ -1010,16 +1122,55 @@ variable (string, integer, character, etc).") | |||
| 1010 | (gnus-newsgroup-expunged-tally . 0) | 1122 | (gnus-newsgroup-expunged-tally . 0) |
| 1011 | gnus-cache-removable-articles gnus-newsgroup-cached | 1123 | gnus-cache-removable-articles gnus-newsgroup-cached |
| 1012 | gnus-newsgroup-data gnus-newsgroup-data-reverse | 1124 | gnus-newsgroup-data gnus-newsgroup-data-reverse |
| 1013 | gnus-newsgroup-limit gnus-newsgroup-limits) | 1125 | gnus-newsgroup-limit gnus-newsgroup-limits |
| 1126 | gnus-newsgroup-charset) | ||
| 1014 | "Variables that are buffer-local to the summary buffers.") | 1127 | "Variables that are buffer-local to the summary buffers.") |
| 1015 | 1128 | ||
| 1016 | ;; Byte-compiler warning. | 1129 | ;; Byte-compiler warning. |
| 1017 | (defvar gnus-article-mode-map) | 1130 | (defvar gnus-article-mode-map) |
| 1018 | 1131 | ||
| 1132 | ;; MIME stuff. | ||
| 1133 | |||
| 1134 | (defvar gnus-decode-encoded-word-methods | ||
| 1135 | '(mail-decode-encoded-word-string) | ||
| 1136 | "List of methods used to decode encoded words. | ||
| 1137 | |||
| 1138 | This variable is a list of FUNCTION or (REGEXP . FUNCTION). If item is | ||
| 1139 | FUNCTION, FUNCTION will be apply to all newsgroups. If item is a | ||
| 1140 | (REGEXP . FUNCTION), FUNCTION will be only apply to thes newsgroups | ||
| 1141 | whose names match REGEXP. | ||
| 1142 | |||
| 1143 | For example: | ||
| 1144 | ((\"chinese\" . gnus-decode-encoded-word-string-by-guess) | ||
| 1145 | mail-decode-encoded-word-string | ||
| 1146 | (\"chinese\" . rfc1843-decode-string))") | ||
| 1147 | |||
| 1148 | (defvar gnus-decode-encoded-word-methods-cache nil) | ||
| 1149 | |||
| 1150 | (defun gnus-multi-decode-encoded-word-string (string) | ||
| 1151 | "Apply the functions from `gnus-encoded-word-methods' that match." | ||
| 1152 | (unless (and gnus-decode-encoded-word-methods-cache | ||
| 1153 | (eq gnus-newsgroup-name | ||
| 1154 | (car gnus-decode-encoded-word-methods-cache))) | ||
| 1155 | (setq gnus-decode-encoded-word-methods-cache (list gnus-newsgroup-name)) | ||
| 1156 | (mapcar (lambda (x) | ||
| 1157 | (if (symbolp x) | ||
| 1158 | (nconc gnus-decode-encoded-word-methods-cache (list x)) | ||
| 1159 | (if (and gnus-newsgroup-name | ||
| 1160 | (string-match (car x) gnus-newsgroup-name)) | ||
| 1161 | (nconc gnus-decode-encoded-word-methods-cache | ||
| 1162 | (list (cdr x)))))) | ||
| 1163 | gnus-decode-encoded-word-methods)) | ||
| 1164 | (let ((xlist gnus-decode-encoded-word-methods-cache)) | ||
| 1165 | (pop xlist) | ||
| 1166 | (while xlist | ||
| 1167 | (setq string (funcall (pop xlist) string)))) | ||
| 1168 | string) | ||
| 1169 | |||
| 1019 | ;; Subject simplification. | 1170 | ;; Subject simplification. |
| 1020 | 1171 | ||
| 1021 | (defun gnus-simplify-whitespace (str) | 1172 | (defun gnus-simplify-whitespace (str) |
| 1022 | "Remove excessive whitespace." | 1173 | "Remove excessive whitespace from STR." |
| 1023 | (let ((mystr str)) | 1174 | (let ((mystr str)) |
| 1024 | ;; Multiple spaces. | 1175 | ;; Multiple spaces. |
| 1025 | (while (string-match "[ \t][ \t]+" mystr) | 1176 | (while (string-match "[ \t][ \t]+" mystr) |
| @@ -1064,7 +1215,7 @@ If RE-ONLY is non-nil, strip leading `Re:'s only." | |||
| 1064 | (defsubst gnus-simplify-buffer-fuzzy-step (regexp &optional newtext) | 1215 | (defsubst gnus-simplify-buffer-fuzzy-step (regexp &optional newtext) |
| 1065 | (goto-char (point-min)) | 1216 | (goto-char (point-min)) |
| 1066 | (while (re-search-forward regexp nil t) | 1217 | (while (re-search-forward regexp nil t) |
| 1067 | (replace-match (or newtext "")))) | 1218 | (replace-match (or newtext "")))) |
| 1068 | 1219 | ||
| 1069 | (defun gnus-simplify-buffer-fuzzy () | 1220 | (defun gnus-simplify-buffer-fuzzy () |
| 1070 | "Simplify string in the buffer fuzzily. | 1221 | "Simplify string in the buffer fuzzily. |
| @@ -1072,7 +1223,7 @@ The string in the accessible portion of the current buffer is simplified. | |||
| 1072 | It is assumed to be a single-line subject. | 1223 | It is assumed to be a single-line subject. |
| 1073 | Whitespace is generally cleaned up, and miscellaneous leading/trailing | 1224 | Whitespace is generally cleaned up, and miscellaneous leading/trailing |
| 1074 | matter is removed. Additional things can be deleted by setting | 1225 | matter is removed. Additional things can be deleted by setting |
| 1075 | gnus-simplify-subject-fuzzy-regexp." | 1226 | `gnus-simplify-subject-fuzzy-regexp'." |
| 1076 | (let ((case-fold-search t) | 1227 | (let ((case-fold-search t) |
| 1077 | (modified-tick)) | 1228 | (modified-tick)) |
| 1078 | (gnus-simplify-buffer-fuzzy-step "\t" " ") | 1229 | (gnus-simplify-buffer-fuzzy-step "\t" " ") |
| @@ -1196,6 +1347,8 @@ increase the score of each group you read." | |||
| 1196 | "\M-\C-h" gnus-summary-hide-thread | 1347 | "\M-\C-h" gnus-summary-hide-thread |
| 1197 | "\M-\C-f" gnus-summary-next-thread | 1348 | "\M-\C-f" gnus-summary-next-thread |
| 1198 | "\M-\C-b" gnus-summary-prev-thread | 1349 | "\M-\C-b" gnus-summary-prev-thread |
| 1350 | [(meta down)] gnus-summary-next-thread | ||
| 1351 | [(meta up)] gnus-summary-prev-thread | ||
| 1199 | "\M-\C-u" gnus-summary-up-thread | 1352 | "\M-\C-u" gnus-summary-up-thread |
| 1200 | "\M-\C-d" gnus-summary-down-thread | 1353 | "\M-\C-d" gnus-summary-down-thread |
| 1201 | "&" gnus-summary-execute-command | 1354 | "&" gnus-summary-execute-command |
| @@ -1206,6 +1359,7 @@ increase the score of each group you read." | |||
| 1206 | "\C-c\M-\C-s" gnus-summary-limit-include-expunged | 1359 | "\C-c\M-\C-s" gnus-summary-limit-include-expunged |
| 1207 | "\C-c\C-s\C-n" gnus-summary-sort-by-number | 1360 | "\C-c\C-s\C-n" gnus-summary-sort-by-number |
| 1208 | "\C-c\C-s\C-l" gnus-summary-sort-by-lines | 1361 | "\C-c\C-s\C-l" gnus-summary-sort-by-lines |
| 1362 | "\C-c\C-s\C-c" gnus-summary-sort-by-chars | ||
| 1209 | "\C-c\C-s\C-a" gnus-summary-sort-by-author | 1363 | "\C-c\C-s\C-a" gnus-summary-sort-by-author |
| 1210 | "\C-c\C-s\C-s" gnus-summary-sort-by-subject | 1364 | "\C-c\C-s\C-s" gnus-summary-sort-by-subject |
| 1211 | "\C-c\C-s\C-d" gnus-summary-sort-by-date | 1365 | "\C-c\C-s\C-d" gnus-summary-sort-by-date |
| @@ -1215,7 +1369,6 @@ increase the score of each group you read." | |||
| 1215 | "\M-g" gnus-summary-rescan-group | 1369 | "\M-g" gnus-summary-rescan-group |
| 1216 | "w" gnus-summary-stop-page-breaking | 1370 | "w" gnus-summary-stop-page-breaking |
| 1217 | "\C-c\C-r" gnus-summary-caesar-message | 1371 | "\C-c\C-r" gnus-summary-caesar-message |
| 1218 | "\M-t" gnus-summary-toggle-mime | ||
| 1219 | "f" gnus-summary-followup | 1372 | "f" gnus-summary-followup |
| 1220 | "F" gnus-summary-followup-with-original | 1373 | "F" gnus-summary-followup-with-original |
| 1221 | "C" gnus-summary-cancel-article | 1374 | "C" gnus-summary-cancel-article |
| @@ -1237,13 +1390,14 @@ increase the score of each group you read." | |||
| 1237 | "a" gnus-summary-post-news | 1390 | "a" gnus-summary-post-news |
| 1238 | "x" gnus-summary-limit-to-unread | 1391 | "x" gnus-summary-limit-to-unread |
| 1239 | "s" gnus-summary-isearch-article | 1392 | "s" gnus-summary-isearch-article |
| 1240 | "t" gnus-article-hide-headers | 1393 | "t" gnus-summary-toggle-header |
| 1241 | "g" gnus-summary-show-article | 1394 | "g" gnus-summary-show-article |
| 1242 | "l" gnus-summary-goto-last-article | 1395 | "l" gnus-summary-goto-last-article |
| 1243 | "\C-c\C-v\C-v" gnus-uu-decode-uu-view | 1396 | "\C-c\C-v\C-v" gnus-uu-decode-uu-view |
| 1244 | "\C-d" gnus-summary-enter-digest-group | 1397 | "\C-d" gnus-summary-enter-digest-group |
| 1245 | "\M-\C-d" gnus-summary-read-document | 1398 | "\M-\C-d" gnus-summary-read-document |
| 1246 | "\M-\C-e" gnus-summary-edit-parameters | 1399 | "\M-\C-e" gnus-summary-edit-parameters |
| 1400 | "\M-\C-a" gnus-summary-customize-parameters | ||
| 1247 | "\C-c\C-b" gnus-bug | 1401 | "\C-c\C-b" gnus-bug |
| 1248 | "*" gnus-cache-enter-article | 1402 | "*" gnus-cache-enter-article |
| 1249 | "\M-*" gnus-cache-remove-article | 1403 | "\M-*" gnus-cache-remove-article |
| @@ -1254,6 +1408,9 @@ increase the score of each group you read." | |||
| 1254 | "\M-i" gnus-symbolic-argument | 1408 | "\M-i" gnus-symbolic-argument |
| 1255 | "h" gnus-summary-select-article-buffer | 1409 | "h" gnus-summary-select-article-buffer |
| 1256 | 1410 | ||
| 1411 | "b" gnus-article-view-part | ||
| 1412 | "\M-t" gnus-summary-toggle-display-buttonized | ||
| 1413 | |||
| 1257 | "V" gnus-summary-score-map | 1414 | "V" gnus-summary-score-map |
| 1258 | "X" gnus-uu-extract-map | 1415 | "X" gnus-uu-extract-map |
| 1259 | "S" gnus-summary-send-map) | 1416 | "S" gnus-summary-send-map) |
| @@ -1295,12 +1452,14 @@ increase the score of each group you read." | |||
| 1295 | "a" gnus-summary-limit-to-author | 1452 | "a" gnus-summary-limit-to-author |
| 1296 | "u" gnus-summary-limit-to-unread | 1453 | "u" gnus-summary-limit-to-unread |
| 1297 | "m" gnus-summary-limit-to-marks | 1454 | "m" gnus-summary-limit-to-marks |
| 1455 | "M" gnus-summary-limit-exclude-marks | ||
| 1298 | "v" gnus-summary-limit-to-score | 1456 | "v" gnus-summary-limit-to-score |
| 1299 | "*" gnus-summary-limit-include-cached | 1457 | "*" gnus-summary-limit-include-cached |
| 1300 | "D" gnus-summary-limit-include-dormant | 1458 | "D" gnus-summary-limit-include-dormant |
| 1301 | "T" gnus-summary-limit-include-thread | 1459 | "T" gnus-summary-limit-include-thread |
| 1302 | "d" gnus-summary-limit-exclude-dormant | 1460 | "d" gnus-summary-limit-exclude-dormant |
| 1303 | "t" gnus-summary-limit-to-age | 1461 | "t" gnus-summary-limit-to-age |
| 1462 | "x" gnus-summary-limit-to-extra | ||
| 1304 | "E" gnus-summary-limit-include-expunged | 1463 | "E" gnus-summary-limit-include-expunged |
| 1305 | "c" gnus-summary-limit-exclude-childless-dormant | 1464 | "c" gnus-summary-limit-exclude-childless-dormant |
| 1306 | "C" gnus-summary-limit-mark-excluded-as-read) | 1465 | "C" gnus-summary-limit-mark-excluded-as-read) |
| @@ -1371,11 +1530,13 @@ increase the score of each group you read." | |||
| 1371 | "e" gnus-summary-end-of-article | 1530 | "e" gnus-summary-end-of-article |
| 1372 | "^" gnus-summary-refer-parent-article | 1531 | "^" gnus-summary-refer-parent-article |
| 1373 | "r" gnus-summary-refer-parent-article | 1532 | "r" gnus-summary-refer-parent-article |
| 1533 | "D" gnus-summary-enter-digest-group | ||
| 1374 | "R" gnus-summary-refer-references | 1534 | "R" gnus-summary-refer-references |
| 1375 | "T" gnus-summary-refer-thread | 1535 | "T" gnus-summary-refer-thread |
| 1376 | "g" gnus-summary-show-article | 1536 | "g" gnus-summary-show-article |
| 1377 | "s" gnus-summary-isearch-article | 1537 | "s" gnus-summary-isearch-article |
| 1378 | "P" gnus-summary-print-article) | 1538 | "P" gnus-summary-print-article |
| 1539 | "t" gnus-article-babel) | ||
| 1379 | 1540 | ||
| 1380 | (gnus-define-keys (gnus-summary-wash-map "W" gnus-summary-mode-map) | 1541 | (gnus-define-keys (gnus-summary-wash-map "W" gnus-summary-mode-map) |
| 1381 | "b" gnus-article-add-buttons | 1542 | "b" gnus-article-add-buttons |
| @@ -1383,15 +1544,19 @@ increase the score of each group you read." | |||
| 1383 | "o" gnus-article-treat-overstrike | 1544 | "o" gnus-article-treat-overstrike |
| 1384 | "e" gnus-article-emphasize | 1545 | "e" gnus-article-emphasize |
| 1385 | "w" gnus-article-fill-cited-article | 1546 | "w" gnus-article-fill-cited-article |
| 1547 | "Q" gnus-article-fill-long-lines | ||
| 1548 | "C" gnus-article-capitalize-sentences | ||
| 1386 | "c" gnus-article-remove-cr | 1549 | "c" gnus-article-remove-cr |
| 1387 | "q" gnus-article-de-quoted-unreadable | 1550 | "q" gnus-article-de-quoted-unreadable |
| 1551 | "6" gnus-article-de-base64-unreadable | ||
| 1552 | "Z" gnus-article-decode-HZ | ||
| 1553 | "h" gnus-article-wash-html | ||
| 1388 | "f" gnus-article-display-x-face | 1554 | "f" gnus-article-display-x-face |
| 1389 | "l" gnus-summary-stop-page-breaking | 1555 | "l" gnus-summary-stop-page-breaking |
| 1390 | "r" gnus-summary-caesar-message | 1556 | "r" gnus-summary-caesar-message |
| 1391 | "t" gnus-article-hide-headers | 1557 | "t" gnus-summary-toggle-header |
| 1392 | "v" gnus-summary-verbose-headers | 1558 | "v" gnus-summary-verbose-headers |
| 1393 | "m" gnus-summary-toggle-mime | 1559 | "H" gnus-article-strip-headers-in-body |
| 1394 | "h" gnus-article-treat-html | ||
| 1395 | "d" gnus-article-treat-dumbquotes) | 1560 | "d" gnus-article-treat-dumbquotes) |
| 1396 | 1561 | ||
| 1397 | (gnus-define-keys (gnus-summary-wash-hide-map "W" gnus-summary-wash-map) | 1562 | (gnus-define-keys (gnus-summary-wash-hide-map "W" gnus-summary-wash-map) |
| @@ -1401,7 +1566,9 @@ increase the score of each group you read." | |||
| 1401 | "s" gnus-article-hide-signature | 1566 | "s" gnus-article-hide-signature |
| 1402 | "c" gnus-article-hide-citation | 1567 | "c" gnus-article-hide-citation |
| 1403 | "C" gnus-article-hide-citation-in-followups | 1568 | "C" gnus-article-hide-citation-in-followups |
| 1569 | "l" gnus-article-hide-list-identifiers | ||
| 1404 | "p" gnus-article-hide-pgp | 1570 | "p" gnus-article-hide-pgp |
| 1571 | "B" gnus-article-strip-banner | ||
| 1405 | "P" gnus-article-hide-pem | 1572 | "P" gnus-article-hide-pem |
| 1406 | "\C-c" gnus-article-hide-citation-maybe) | 1573 | "\C-c" gnus-article-hide-citation-maybe) |
| 1407 | 1574 | ||
| @@ -1411,6 +1578,12 @@ increase the score of each group you read." | |||
| 1411 | "c" gnus-article-highlight-citation | 1578 | "c" gnus-article-highlight-citation |
| 1412 | "s" gnus-article-highlight-signature) | 1579 | "s" gnus-article-highlight-signature) |
| 1413 | 1580 | ||
| 1581 | (gnus-define-keys (gnus-summary-wash-mime-map "M" gnus-summary-wash-map) | ||
| 1582 | "w" gnus-article-decode-mime-words | ||
| 1583 | "c" gnus-article-decode-charset | ||
| 1584 | "v" gnus-mime-view-all-parts | ||
| 1585 | "b" gnus-article-view-part) | ||
| 1586 | |||
| 1414 | (gnus-define-keys (gnus-summary-wash-time-map "T" gnus-summary-wash-map) | 1587 | (gnus-define-keys (gnus-summary-wash-time-map "T" gnus-summary-wash-map) |
| 1415 | "z" gnus-article-date-ut | 1588 | "z" gnus-article-date-ut |
| 1416 | "u" gnus-article-date-ut | 1589 | "u" gnus-article-date-ut |
| @@ -1426,7 +1599,8 @@ increase the score of each group you read." | |||
| 1426 | "m" gnus-article-strip-multiple-blank-lines | 1599 | "m" gnus-article-strip-multiple-blank-lines |
| 1427 | "a" gnus-article-strip-blank-lines | 1600 | "a" gnus-article-strip-blank-lines |
| 1428 | "A" gnus-article-strip-all-blank-lines | 1601 | "A" gnus-article-strip-all-blank-lines |
| 1429 | "s" gnus-article-strip-leading-space) | 1602 | "s" gnus-article-strip-leading-space |
| 1603 | "e" gnus-article-strip-trailing-space) | ||
| 1430 | 1604 | ||
| 1431 | (gnus-define-keys (gnus-summary-help-map "H" gnus-summary-mode-map) | 1605 | (gnus-define-keys (gnus-summary-help-map "H" gnus-summary-mode-map) |
| 1432 | "v" gnus-version | 1606 | "v" gnus-version |
| @@ -1440,6 +1614,7 @@ increase the score of each group you read." | |||
| 1440 | "\M-\C-e" gnus-summary-expire-articles-now | 1614 | "\M-\C-e" gnus-summary-expire-articles-now |
| 1441 | "\177" gnus-summary-delete-article | 1615 | "\177" gnus-summary-delete-article |
| 1442 | [delete] gnus-summary-delete-article | 1616 | [delete] gnus-summary-delete-article |
| 1617 | [backspace] gnus-summary-delete-article | ||
| 1443 | "m" gnus-summary-move-article | 1618 | "m" gnus-summary-move-article |
| 1444 | "r" gnus-summary-respool-article | 1619 | "r" gnus-summary-respool-article |
| 1445 | "w" gnus-summary-edit-article | 1620 | "w" gnus-summary-edit-article |
| @@ -1460,7 +1635,17 @@ increase the score of each group you read." | |||
| 1460 | "h" gnus-summary-save-article-folder | 1635 | "h" gnus-summary-save-article-folder |
| 1461 | "v" gnus-summary-save-article-vm | 1636 | "v" gnus-summary-save-article-vm |
| 1462 | "p" gnus-summary-pipe-output | 1637 | "p" gnus-summary-pipe-output |
| 1463 | "s" gnus-soup-add-article)) | 1638 | "s" gnus-soup-add-article) |
| 1639 | |||
| 1640 | (gnus-define-keys (gnus-summary-mime-map "K" gnus-summary-mode-map) | ||
| 1641 | "b" gnus-summary-display-buttonized | ||
| 1642 | "m" gnus-summary-repair-multipart | ||
| 1643 | "v" gnus-article-view-part | ||
| 1644 | "o" gnus-article-save-part | ||
| 1645 | "c" gnus-article-copy-part | ||
| 1646 | "e" gnus-article-externalize-part | ||
| 1647 | "i" gnus-article-inline-part | ||
| 1648 | "|" gnus-article-pipe-part)) | ||
| 1464 | 1649 | ||
| 1465 | (defun gnus-summary-make-menu-bar () | 1650 | (defun gnus-summary-make-menu-bar () |
| 1466 | (gnus-turn-off-edit-menu 'summary) | 1651 | (gnus-turn-off-edit-menu 'summary) |
| @@ -1503,13 +1688,21 @@ increase the score of each group you read." | |||
| 1503 | ["Headers" gnus-article-hide-headers t] | 1688 | ["Headers" gnus-article-hide-headers t] |
| 1504 | ["Signature" gnus-article-hide-signature t] | 1689 | ["Signature" gnus-article-hide-signature t] |
| 1505 | ["Citation" gnus-article-hide-citation t] | 1690 | ["Citation" gnus-article-hide-citation t] |
| 1691 | ["List identifiers" gnus-article-hide-list-identifiers t] | ||
| 1506 | ["PGP" gnus-article-hide-pgp t] | 1692 | ["PGP" gnus-article-hide-pgp t] |
| 1693 | ["Banner" gnus-article-strip-banner t] | ||
| 1507 | ["Boring headers" gnus-article-hide-boring-headers t]) | 1694 | ["Boring headers" gnus-article-hide-boring-headers t]) |
| 1508 | ("Highlight" | 1695 | ("Highlight" |
| 1509 | ["All" gnus-article-highlight t] | 1696 | ["All" gnus-article-highlight t] |
| 1510 | ["Headers" gnus-article-highlight-headers t] | 1697 | ["Headers" gnus-article-highlight-headers t] |
| 1511 | ["Signature" gnus-article-highlight-signature t] | 1698 | ["Signature" gnus-article-highlight-signature t] |
| 1512 | ["Citation" gnus-article-highlight-citation t]) | 1699 | ["Citation" gnus-article-highlight-citation t]) |
| 1700 | ("MIME" | ||
| 1701 | ["Words" gnus-article-decode-mime-words t] | ||
| 1702 | ["Charset" gnus-article-decode-charset t] | ||
| 1703 | ["QP" gnus-article-de-quoted-unreadable t] | ||
| 1704 | ["Base64" gnus-article-de-base64-unreadable t] | ||
| 1705 | ["View all" gnus-mime-view-all-parts t]) | ||
| 1513 | ("Date" | 1706 | ("Date" |
| 1514 | ["Local" gnus-article-date-local t] | 1707 | ["Local" gnus-article-date-local t] |
| 1515 | ["ISO8601" gnus-article-date-iso8601 t] | 1708 | ["ISO8601" gnus-article-date-iso8601 t] |
| @@ -1524,23 +1717,27 @@ increase the score of each group you read." | |||
| 1524 | ["Trailing" gnus-article-remove-trailing-blank-lines t] | 1717 | ["Trailing" gnus-article-remove-trailing-blank-lines t] |
| 1525 | ["All of the above" gnus-article-strip-blank-lines t] | 1718 | ["All of the above" gnus-article-strip-blank-lines t] |
| 1526 | ["All" gnus-article-strip-all-blank-lines t] | 1719 | ["All" gnus-article-strip-all-blank-lines t] |
| 1527 | ["Leading space" gnus-article-strip-leading-space t]) | 1720 | ["Leading space" gnus-article-strip-leading-space t] |
| 1721 | ["Trailing space" gnus-article-strip-trailing-space t]) | ||
| 1528 | ["Overstrike" gnus-article-treat-overstrike t] | 1722 | ["Overstrike" gnus-article-treat-overstrike t] |
| 1529 | ["Dumb quotes" gnus-article-treat-dumbquotes t] | 1723 | ["Dumb quotes" gnus-article-treat-dumbquotes t] |
| 1530 | ["Emphasis" gnus-article-emphasize t] | 1724 | ["Emphasis" gnus-article-emphasize t] |
| 1531 | ["Word wrap" gnus-article-fill-cited-article t] | 1725 | ["Word wrap" gnus-article-fill-cited-article t] |
| 1726 | ["Fill long lines" gnus-article-fill-long-lines t] | ||
| 1727 | ["Capitalize sentences" gnus-article-capitalize-sentences t] | ||
| 1532 | ["CR" gnus-article-remove-cr t] | 1728 | ["CR" gnus-article-remove-cr t] |
| 1533 | ["Show X-Face" gnus-article-display-x-face t] | 1729 | ["Show X-Face" gnus-article-display-x-face t] |
| 1534 | ["Quoted-Printable" gnus-article-de-quoted-unreadable t] | 1730 | ["Quoted-Printable" gnus-article-de-quoted-unreadable t] |
| 1535 | ["UnHTMLize" gnus-article-treat-html t] | 1731 | ["Base64" gnus-article-de-base64-unreadable t] |
| 1536 | ["Rot 13" gnus-summary-caesar-message t] | 1732 | ["Rot 13" gnus-summary-caesar-message t] |
| 1537 | ["Unix pipe" gnus-summary-pipe-message t] | 1733 | ["Unix pipe" gnus-summary-pipe-message t] |
| 1538 | ["Add buttons" gnus-article-add-buttons t] | 1734 | ["Add buttons" gnus-article-add-buttons t] |
| 1539 | ["Add buttons to head" gnus-article-add-buttons-to-head t] | 1735 | ["Add buttons to head" gnus-article-add-buttons-to-head t] |
| 1540 | ["Stop page breaking" gnus-summary-stop-page-breaking t] | 1736 | ["Stop page breaking" gnus-summary-stop-page-breaking t] |
| 1541 | ["Toggle MIME" gnus-summary-toggle-mime t] | ||
| 1542 | ["Verbose header" gnus-summary-verbose-headers t] | 1737 | ["Verbose header" gnus-summary-verbose-headers t] |
| 1543 | ["Toggle header" gnus-summary-toggle-header t]) | 1738 | ["Toggle header" gnus-summary-toggle-header t] |
| 1739 | ["Html" gnus-article-wash-html t] | ||
| 1740 | ["HZ" gnus-article-decode-HZ t]) | ||
| 1544 | ("Output" | 1741 | ("Output" |
| 1545 | ["Save in default format" gnus-summary-save-article t] | 1742 | ["Save in default format" gnus-summary-save-article t] |
| 1546 | ["Save in file" gnus-summary-save-article-file t] | 1743 | ["Save in file" gnus-summary-save-article-file t] |
| @@ -1584,6 +1781,7 @@ increase the score of each group you read." | |||
| 1584 | ("Cache" | 1781 | ("Cache" |
| 1585 | ["Enter article" gnus-cache-enter-article t] | 1782 | ["Enter article" gnus-cache-enter-article t] |
| 1586 | ["Remove article" gnus-cache-remove-article t]) | 1783 | ["Remove article" gnus-cache-remove-article t]) |
| 1784 | ["Translate" gnus-article-babel t] | ||
| 1587 | ["Select article buffer" gnus-summary-select-article-buffer t] | 1785 | ["Select article buffer" gnus-summary-select-article-buffer t] |
| 1588 | ["Enter digest buffer" gnus-summary-enter-digest-group t] | 1786 | ["Enter digest buffer" gnus-summary-enter-digest-group t] |
| 1589 | ["Isearch article..." gnus-summary-isearch-article t] | 1787 | ["Isearch article..." gnus-summary-isearch-article t] |
| @@ -1618,8 +1816,7 @@ increase the score of each group you read." | |||
| 1618 | ["Mark thread as read" gnus-summary-kill-thread t] | 1816 | ["Mark thread as read" gnus-summary-kill-thread t] |
| 1619 | ["Lower thread score" gnus-summary-lower-thread t] | 1817 | ["Lower thread score" gnus-summary-lower-thread t] |
| 1620 | ["Raise thread score" gnus-summary-raise-thread t] | 1818 | ["Raise thread score" gnus-summary-raise-thread t] |
| 1621 | ["Rethread current" gnus-summary-rethread-current t] | 1819 | ["Rethread current" gnus-summary-rethread-current t])) |
| 1622 | )) | ||
| 1623 | 1820 | ||
| 1624 | (easy-menu-define | 1821 | (easy-menu-define |
| 1625 | gnus-summary-post-menu gnus-summary-mode-map "" | 1822 | gnus-summary-post-menu gnus-summary-mode-map "" |
| @@ -1674,6 +1871,7 @@ increase the score of each group you read." | |||
| 1674 | ["Subject..." gnus-summary-limit-to-subject t] | 1871 | ["Subject..." gnus-summary-limit-to-subject t] |
| 1675 | ["Author..." gnus-summary-limit-to-author t] | 1872 | ["Author..." gnus-summary-limit-to-author t] |
| 1676 | ["Age..." gnus-summary-limit-to-age t] | 1873 | ["Age..." gnus-summary-limit-to-age t] |
| 1874 | ["Extra..." gnus-summary-limit-to-extra t] | ||
| 1677 | ["Score" gnus-summary-limit-to-score t] | 1875 | ["Score" gnus-summary-limit-to-score t] |
| 1678 | ["Unread" gnus-summary-limit-to-unread t] | 1876 | ["Unread" gnus-summary-limit-to-unread t] |
| 1679 | ["Non-dormant" gnus-summary-limit-exclude-dormant t] | 1877 | ["Non-dormant" gnus-summary-limit-exclude-dormant t] |
| @@ -1683,6 +1881,7 @@ increase the score of each group you read." | |||
| 1683 | ["Hide childless dormant" | 1881 | ["Hide childless dormant" |
| 1684 | gnus-summary-limit-exclude-childless-dormant t] | 1882 | gnus-summary-limit-exclude-childless-dormant t] |
| 1685 | ;;["Hide thread" gnus-summary-limit-exclude-thread t] | 1883 | ;;["Hide thread" gnus-summary-limit-exclude-thread t] |
| 1884 | ["Hide marked" gnus-summary-limit-exclude-marks t] | ||
| 1686 | ["Show expunged" gnus-summary-show-all-expunged t]) | 1885 | ["Show expunged" gnus-summary-show-all-expunged t]) |
| 1687 | ("Process Mark" | 1886 | ("Process Mark" |
| 1688 | ["Set mark" gnus-summary-mark-as-processable t] | 1887 | ["Set mark" gnus-summary-mark-as-processable t] |
| @@ -1729,7 +1928,8 @@ increase the score of each group you read." | |||
| 1729 | ["Sort by subject" gnus-summary-sort-by-subject t] | 1928 | ["Sort by subject" gnus-summary-sort-by-subject t] |
| 1730 | ["Sort by date" gnus-summary-sort-by-date t] | 1929 | ["Sort by date" gnus-summary-sort-by-date t] |
| 1731 | ["Sort by score" gnus-summary-sort-by-score t] | 1930 | ["Sort by score" gnus-summary-sort-by-score t] |
| 1732 | ["Sort by lines" gnus-summary-sort-by-lines t]) | 1931 | ["Sort by lines" gnus-summary-sort-by-lines t] |
| 1932 | ["Sort by characters" gnus-summary-sort-by-chars t]) | ||
| 1733 | ("Help" | 1933 | ("Help" |
| 1734 | ["Fetch group FAQ" gnus-summary-fetch-faq t] | 1934 | ["Fetch group FAQ" gnus-summary-fetch-faq t] |
| 1735 | ["Describe group" gnus-summary-describe-group t] | 1935 | ["Describe group" gnus-summary-describe-group t] |
| @@ -1753,6 +1953,7 @@ increase the score of each group you read." | |||
| 1753 | ["Edit local kill file" gnus-summary-edit-local-kill t] | 1953 | ["Edit local kill file" gnus-summary-edit-local-kill t] |
| 1754 | ["Edit main kill file" gnus-summary-edit-global-kill t] | 1954 | ["Edit main kill file" gnus-summary-edit-global-kill t] |
| 1755 | ["Edit group parameters" gnus-summary-edit-parameters t] | 1955 | ["Edit group parameters" gnus-summary-edit-parameters t] |
| 1956 | ["Customize group parameters" gnus-summary-customize-parameters t] | ||
| 1756 | ["Send a bug report" gnus-bug t] | 1957 | ["Send a bug report" gnus-bug t] |
| 1757 | ("Exit" | 1958 | ("Exit" |
| 1758 | ["Catchup and exit" gnus-summary-catchup-and-exit t] | 1959 | ["Catchup and exit" gnus-summary-catchup-and-exit t] |
| @@ -1783,6 +1984,7 @@ increase the score of each group you read." | |||
| 1783 | ("article body" "body" string) | 1984 | ("article body" "body" string) |
| 1784 | ("article head" "head" string) | 1985 | ("article head" "head" string) |
| 1785 | ("xref" "xref" string) | 1986 | ("xref" "xref" string) |
| 1987 | ("extra header" "extra" string) | ||
| 1786 | ("lines" "lines" number) | 1988 | ("lines" "lines" number) |
| 1787 | ("followups to author" "followup" string))) | 1989 | ("followups to author" "followup" string))) |
| 1788 | (types '((number ("less than" <) | 1990 | (types '((number ("less than" <) |
| @@ -1837,7 +2039,8 @@ increase the score of each group you read." | |||
| 1837 | (list 'gnus-summary-header | 2039 | (list 'gnus-summary-header |
| 1838 | (nth 1 header))) | 2040 | (nth 1 header))) |
| 1839 | (list 'quote (nth 1 (car ts))) | 2041 | (list 'quote (nth 1 (car ts))) |
| 1840 | (list 'gnus-score-default nil) | 2042 | (list 'gnus-score-delta-default |
| 2043 | nil) | ||
| 1841 | (nth 1 (car ps)) | 2044 | (nth 1 (car ps)) |
| 1842 | t) | 2045 | t) |
| 1843 | t) | 2046 | t) |
| @@ -1884,7 +2087,7 @@ The following commands are available: | |||
| 1884 | (setq mode-name "Summary") | 2087 | (setq mode-name "Summary") |
| 1885 | (make-local-variable 'minor-mode-alist) | 2088 | (make-local-variable 'minor-mode-alist) |
| 1886 | (use-local-map gnus-summary-mode-map) | 2089 | (use-local-map gnus-summary-mode-map) |
| 1887 | (buffer-disable-undo (current-buffer)) | 2090 | (buffer-disable-undo) |
| 1888 | (setq buffer-read-only t) ;Disable modification | 2091 | (setq buffer-read-only t) ;Disable modification |
| 1889 | (setq truncate-lines t) | 2092 | (setq truncate-lines t) |
| 1890 | (setq selective-display t) | 2093 | (setq selective-display t) |
| @@ -1897,19 +2100,17 @@ The following commands are available: | |||
| 1897 | (make-local-variable 'gnus-summary-dummy-line-format) | 2100 | (make-local-variable 'gnus-summary-dummy-line-format) |
| 1898 | (make-local-variable 'gnus-summary-dummy-line-format-spec) | 2101 | (make-local-variable 'gnus-summary-dummy-line-format-spec) |
| 1899 | (make-local-variable 'gnus-summary-mark-positions) | 2102 | (make-local-variable 'gnus-summary-mark-positions) |
| 1900 | (make-local-hook 'post-command-hook) | ||
| 1901 | (add-hook 'post-command-hook 'gnus-clear-inboxes-moved nil t) | ||
| 1902 | (make-local-hook 'pre-command-hook) | 2103 | (make-local-hook 'pre-command-hook) |
| 1903 | (add-hook 'pre-command-hook 'gnus-set-global-variables nil t) | 2104 | (add-hook 'pre-command-hook 'gnus-set-global-variables nil t) |
| 1904 | (gnus-run-hooks 'gnus-summary-mode-hook) | 2105 | (gnus-run-hooks 'gnus-summary-mode-hook) |
| 2106 | (mm-enable-multibyte) | ||
| 1905 | (gnus-update-format-specifications nil 'summary 'summary-mode 'summary-dummy) | 2107 | (gnus-update-format-specifications nil 'summary 'summary-mode 'summary-dummy) |
| 1906 | (gnus-update-summary-mark-positions)) | 2108 | (gnus-update-summary-mark-positions)) |
| 1907 | 2109 | ||
| 1908 | (defun gnus-summary-make-local-variables () | 2110 | (defun gnus-summary-make-local-variables () |
| 1909 | "Make all the local summary buffer variables." | 2111 | "Make all the local summary buffer variables." |
| 1910 | (let ((locals gnus-summary-local-variables) | 2112 | (let (global) |
| 1911 | global local) | 2113 | (dolist (local gnus-summary-local-variables) |
| 1912 | (while (setq local (pop locals)) | ||
| 1913 | (if (consp local) | 2114 | (if (consp local) |
| 1914 | (progn | 2115 | (progn |
| 1915 | (if (eq (cdr local) 'global) | 2116 | (if (eq (cdr local) 'global) |
| @@ -1917,11 +2118,9 @@ The following commands are available: | |||
| 1917 | (setq global (symbol-value (car local))) | 2118 | (setq global (symbol-value (car local))) |
| 1918 | ;; Use the value from the list. | 2119 | ;; Use the value from the list. |
| 1919 | (setq global (eval (cdr local)))) | 2120 | (setq global (eval (cdr local)))) |
| 1920 | (make-local-variable (car local)) | 2121 | (set (make-local-variable (car local)) global)) |
| 1921 | (set (car local) global)) | ||
| 1922 | ;; Simple nil-valued local variable. | 2122 | ;; Simple nil-valued local variable. |
| 1923 | (make-local-variable local) | 2123 | (set (make-local-variable local) nil))))) |
| 1924 | (set local nil))))) | ||
| 1925 | 2124 | ||
| 1926 | (defun gnus-summary-clear-local-variables () | 2125 | (defun gnus-summary-clear-local-variables () |
| 1927 | (let ((locals gnus-summary-local-variables)) | 2126 | (let ((locals gnus-summary-local-variables)) |
| @@ -2215,26 +2414,6 @@ marks of articles." | |||
| 2215 | ,@forms) | 2414 | ,@forms) |
| 2216 | (gnus-restore-hidden-threads-configuration ,config))))) | 2415 | (gnus-restore-hidden-threads-configuration ,config))))) |
| 2217 | 2416 | ||
| 2218 | (defun gnus-hidden-threads-configuration () | ||
| 2219 | "Return the current hidden threads configuration." | ||
| 2220 | (save-excursion | ||
| 2221 | (let (config) | ||
| 2222 | (goto-char (point-min)) | ||
| 2223 | (while (search-forward "\r" nil t) | ||
| 2224 | (push (1- (point)) config)) | ||
| 2225 | config))) | ||
| 2226 | |||
| 2227 | (defun gnus-restore-hidden-threads-configuration (config) | ||
| 2228 | "Restore hidden threads configuration from CONFIG." | ||
| 2229 | (let (point buffer-read-only) | ||
| 2230 | (while (setq point (pop config)) | ||
| 2231 | (when (and (< point (point-max)) | ||
| 2232 | (goto-char point) | ||
| 2233 | (= (following-char) ?\n)) | ||
| 2234 | (subst-char-in-region point (1+ point) ?\n ?\r))))) | ||
| 2235 | |||
| 2236 | ;; This needs to be put here because it uses the | ||
| 2237 | ;; gnus-save-hidden-threads macro | ||
| 2238 | (defun gnus-data-compute-positions () | 2417 | (defun gnus-data-compute-positions () |
| 2239 | "Compute the positions of all articles." | 2418 | "Compute the positions of all articles." |
| 2240 | (setq gnus-newsgroup-data-reverse nil) | 2419 | (setq gnus-newsgroup-data-reverse nil) |
| @@ -2250,6 +2429,25 @@ marks of articles." | |||
| 2250 | (setq data (cdr data)) | 2429 | (setq data (cdr data)) |
| 2251 | (forward-line 1)))))) | 2430 | (forward-line 1)))))) |
| 2252 | 2431 | ||
| 2432 | (defun gnus-hidden-threads-configuration () | ||
| 2433 | "Return the current hidden threads configuration." | ||
| 2434 | (save-excursion | ||
| 2435 | (let (config) | ||
| 2436 | (goto-char (point-min)) | ||
| 2437 | (while (search-forward "\r" nil t) | ||
| 2438 | (push (1- (point)) config)) | ||
| 2439 | config))) | ||
| 2440 | |||
| 2441 | (defun gnus-restore-hidden-threads-configuration (config) | ||
| 2442 | "Restore hidden threads configuration from CONFIG." | ||
| 2443 | (save-excursion | ||
| 2444 | (let (point buffer-read-only) | ||
| 2445 | (while (setq point (pop config)) | ||
| 2446 | (when (and (< point (point-max)) | ||
| 2447 | (goto-char point) | ||
| 2448 | (eq (char-after) ?\n)) | ||
| 2449 | (subst-char-in-region point (1+ point) ?\n ?\r)))))) | ||
| 2450 | |||
| 2253 | ;; Various summary mode internalish functions. | 2451 | ;; Various summary mode internalish functions. |
| 2254 | 2452 | ||
| 2255 | (defun gnus-mouse-pick-article (e) | 2453 | (defun gnus-mouse-pick-article (e) |
| @@ -2258,9 +2456,10 @@ marks of articles." | |||
| 2258 | (gnus-summary-next-page nil t)) | 2456 | (gnus-summary-next-page nil t)) |
| 2259 | 2457 | ||
| 2260 | (defun gnus-summary-set-display-table () | 2458 | (defun gnus-summary-set-display-table () |
| 2261 | ;; Change the display table. Odd characters have a tendency to mess | 2459 | "Change the display table. |
| 2262 | ;; up nicely formatted displays - we make all possible glyphs | 2460 | Odd characters have a tendency to mess |
| 2263 | ;; display only a single character. | 2461 | up nicely formatted displays - we make all possible glyphs |
| 2462 | display only a single character." | ||
| 2264 | 2463 | ||
| 2265 | ;; We start from the standard display table, if any. | 2464 | ;; We start from the standard display table, if any. |
| 2266 | (let ((table (or (copy-sequence standard-display-table) | 2465 | (let ((table (or (copy-sequence standard-display-table) |
| @@ -2304,9 +2503,9 @@ marks of articles." | |||
| 2304 | t))) | 2503 | t))) |
| 2305 | 2504 | ||
| 2306 | (defun gnus-set-global-variables () | 2505 | (defun gnus-set-global-variables () |
| 2307 | ;; Set the global equivalents of the summary buffer-local variables | 2506 | "Set the global equivalents of the buffer-local variables. |
| 2308 | ;; to the latest values they had. These reflect the summary buffer | 2507 | They are set to the latest values they had. These reflect the summary |
| 2309 | ;; that was in action when the last article was fetched. | 2508 | buffer that was in action when the last article was fetched." |
| 2310 | (when (eq major-mode 'gnus-summary-mode) | 2509 | (when (eq major-mode 'gnus-summary-mode) |
| 2311 | (setq gnus-summary-buffer (current-buffer)) | 2510 | (setq gnus-summary-buffer (current-buffer)) |
| 2312 | (let ((name gnus-newsgroup-name) | 2511 | (let ((name gnus-newsgroup-name) |
| @@ -2319,7 +2518,8 @@ marks of articles." | |||
| 2319 | (original gnus-original-article-buffer) | 2518 | (original gnus-original-article-buffer) |
| 2320 | (gac gnus-article-current) | 2519 | (gac gnus-article-current) |
| 2321 | (reffed gnus-reffed-article-number) | 2520 | (reffed gnus-reffed-article-number) |
| 2322 | (score-file gnus-current-score-file)) | 2521 | (score-file gnus-current-score-file) |
| 2522 | (default-charset gnus-newsgroup-charset)) | ||
| 2323 | (save-excursion | 2523 | (save-excursion |
| 2324 | (set-buffer gnus-group-buffer) | 2524 | (set-buffer gnus-group-buffer) |
| 2325 | (setq gnus-newsgroup-name name | 2525 | (setq gnus-newsgroup-name name |
| @@ -2332,7 +2532,8 @@ marks of articles." | |||
| 2332 | gnus-article-buffer article-buffer | 2532 | gnus-article-buffer article-buffer |
| 2333 | gnus-original-article-buffer original | 2533 | gnus-original-article-buffer original |
| 2334 | gnus-reffed-article-number reffed | 2534 | gnus-reffed-article-number reffed |
| 2335 | gnus-current-score-file score-file) | 2535 | gnus-current-score-file score-file |
| 2536 | gnus-newsgroup-charset default-charset) | ||
| 2336 | ;; The article buffer also has local variables. | 2537 | ;; The article buffer also has local variables. |
| 2337 | (when (gnus-buffer-live-p gnus-article-buffer) | 2538 | (when (gnus-buffer-live-p gnus-article-buffer) |
| 2338 | (set-buffer gnus-article-buffer) | 2539 | (set-buffer gnus-article-buffer) |
| @@ -2351,7 +2552,8 @@ marks of articles." | |||
| 2351 | (defun gnus-summary-last-article-p (&optional article) | 2552 | (defun gnus-summary-last-article-p (&optional article) |
| 2352 | "Return whether ARTICLE is the last article in the buffer." | 2553 | "Return whether ARTICLE is the last article in the buffer." |
| 2353 | (if (not (setq article (or article (gnus-summary-article-number)))) | 2554 | (if (not (setq article (or article (gnus-summary-article-number)))) |
| 2354 | t ; All non-existent numbers are the last article. :-) | 2555 | ;; All non-existent numbers are the last article. :-) |
| 2556 | t | ||
| 2355 | (not (cdr (gnus-data-find-list article))))) | 2557 | (not (cdr (gnus-data-find-list article))))) |
| 2356 | 2558 | ||
| 2357 | (defun gnus-make-thread-indent-array () | 2559 | (defun gnus-make-thread-indent-array () |
| @@ -2381,7 +2583,7 @@ marks of articles." | |||
| 2381 | (let ((gnus-summary-line-format-spec spec) | 2583 | (let ((gnus-summary-line-format-spec spec) |
| 2382 | (gnus-newsgroup-downloadable '((0 . t)))) | 2584 | (gnus-newsgroup-downloadable '((0 . t)))) |
| 2383 | (gnus-summary-insert-line | 2585 | (gnus-summary-insert-line |
| 2384 | [0 "" "" "" "" "" 0 0 ""] 0 nil 128 t nil "" nil 1) | 2586 | [0 "" "" "" "" "" 0 0 "" nil] 0 nil 128 t nil "" nil 1) |
| 2385 | (goto-char (point-min)) | 2587 | (goto-char (point-min)) |
| 2386 | (setq pos (list (cons 'unread (and (search-forward "\200" nil t) | 2588 | (setq pos (list (cons 'unread (and (search-forward "\200" nil t) |
| 2387 | (- (point) 2))))) | 2589 | (- (point) 2))))) |
| @@ -2405,6 +2607,33 @@ marks of articles." | |||
| 2405 | (point) (progn (eval gnus-summary-dummy-line-format-spec) (point)) | 2607 | (point) (progn (eval gnus-summary-dummy-line-format-spec) (point)) |
| 2406 | (list 'gnus-number gnus-tmp-number 'gnus-intangible gnus-tmp-number))) | 2608 | (list 'gnus-number gnus-tmp-number 'gnus-intangible gnus-tmp-number))) |
| 2407 | 2609 | ||
| 2610 | (defun gnus-summary-from-or-to-or-newsgroups (header) | ||
| 2611 | (let ((to (cdr (assq 'To (mail-header-extra header)))) | ||
| 2612 | (newsgroups (cdr (assq 'Newsgroups (mail-header-extra header)))) | ||
| 2613 | (mail-parse-charset gnus-newsgroup-charset) | ||
| 2614 | (mail-parse-ignored-charsets | ||
| 2615 | (save-excursion (set-buffer gnus-summary-buffer) | ||
| 2616 | gnus-newsgroup-ignored-charsets))) | ||
| 2617 | (cond | ||
| 2618 | ((and to | ||
| 2619 | gnus-ignored-from-addresses | ||
| 2620 | (string-match gnus-ignored-from-addresses | ||
| 2621 | (mail-header-from header))) | ||
| 2622 | (concat "-> " | ||
| 2623 | (or (car (funcall gnus-extract-address-components | ||
| 2624 | (funcall | ||
| 2625 | gnus-decode-encoded-word-function to))) | ||
| 2626 | (funcall gnus-decode-encoded-word-function to)))) | ||
| 2627 | ((and newsgroups | ||
| 2628 | gnus-ignored-from-addresses | ||
| 2629 | (string-match gnus-ignored-from-addresses | ||
| 2630 | (mail-header-from header))) | ||
| 2631 | (concat "=> " newsgroups)) | ||
| 2632 | (t | ||
| 2633 | (or (car (funcall gnus-extract-address-components | ||
| 2634 | (mail-header-from header))) | ||
| 2635 | (mail-header-from header)))))) | ||
| 2636 | |||
| 2408 | (defun gnus-summary-insert-line (gnus-tmp-header | 2637 | (defun gnus-summary-insert-line (gnus-tmp-header |
| 2409 | gnus-tmp-level gnus-tmp-current | 2638 | gnus-tmp-level gnus-tmp-current |
| 2410 | gnus-tmp-unread gnus-tmp-replied | 2639 | gnus-tmp-unread gnus-tmp-replied |
| @@ -2418,7 +2647,7 @@ marks of articles." | |||
| 2418 | (if (or (null gnus-summary-default-score) | 2647 | (if (or (null gnus-summary-default-score) |
| 2419 | (<= (abs (- gnus-tmp-score gnus-summary-default-score)) | 2648 | (<= (abs (- gnus-tmp-score gnus-summary-default-score)) |
| 2420 | gnus-summary-zcore-fuzz)) | 2649 | gnus-summary-zcore-fuzz)) |
| 2421 | ? ;space | 2650 | ? ;Whitespace |
| 2422 | (if (< gnus-tmp-score gnus-summary-default-score) | 2651 | (if (< gnus-tmp-score gnus-summary-default-score) |
| 2423 | gnus-score-below-mark gnus-score-over-mark))) | 2652 | gnus-score-below-mark gnus-score-over-mark))) |
| 2424 | (gnus-tmp-replied | 2653 | (gnus-tmp-replied |
| @@ -2451,7 +2680,7 @@ marks of articles." | |||
| 2451 | (setq gnus-tmp-name gnus-tmp-from)) | 2680 | (setq gnus-tmp-name gnus-tmp-from)) |
| 2452 | (unless (numberp gnus-tmp-lines) | 2681 | (unless (numberp gnus-tmp-lines) |
| 2453 | (setq gnus-tmp-lines 0)) | 2682 | (setq gnus-tmp-lines 0)) |
| 2454 | (gnus-put-text-property-excluding-characters-with-faces | 2683 | (gnus-put-text-property |
| 2455 | (point) | 2684 | (point) |
| 2456 | (progn (eval gnus-summary-line-format-spec) (point)) | 2685 | (progn (eval gnus-summary-line-format-spec) (point)) |
| 2457 | 'gnus-number gnus-tmp-number) | 2686 | 'gnus-number gnus-tmp-number) |
| @@ -2461,7 +2690,7 @@ marks of articles." | |||
| 2461 | (forward-line 1)))) | 2690 | (forward-line 1)))) |
| 2462 | 2691 | ||
| 2463 | (defun gnus-summary-update-line (&optional dont-update) | 2692 | (defun gnus-summary-update-line (&optional dont-update) |
| 2464 | ;; Update summary line after change. | 2693 | "Update summary line after change." |
| 2465 | (when (and gnus-summary-default-score | 2694 | (when (and gnus-summary-default-score |
| 2466 | (not gnus-summary-inhibit-highlight)) | 2695 | (not gnus-summary-inhibit-highlight)) |
| 2467 | (let* ((gnus-summary-inhibit-highlight t) ; Prevent recursion. | 2696 | (let* ((gnus-summary-inhibit-highlight t) ; Prevent recursion. |
| @@ -2483,7 +2712,7 @@ marks of articles." | |||
| 2483 | (if (or (null gnus-summary-default-score) | 2712 | (if (or (null gnus-summary-default-score) |
| 2484 | (<= (abs (- score gnus-summary-default-score)) | 2713 | (<= (abs (- score gnus-summary-default-score)) |
| 2485 | gnus-summary-zcore-fuzz)) | 2714 | gnus-summary-zcore-fuzz)) |
| 2486 | ? ;space | 2715 | ? ;Whitespace |
| 2487 | (if (< score gnus-summary-default-score) | 2716 | (if (< score gnus-summary-default-score) |
| 2488 | gnus-score-below-mark gnus-score-over-mark)) | 2717 | gnus-score-below-mark gnus-score-over-mark)) |
| 2489 | 'score)) | 2718 | 'score)) |
| @@ -2552,7 +2781,7 @@ If NO-DISPLAY, don't generate a summary buffer." | |||
| 2552 | kill-buffer no-display | 2781 | kill-buffer no-display |
| 2553 | select-articles) | 2782 | select-articles) |
| 2554 | (setq show-all nil | 2783 | (setq show-all nil |
| 2555 | select-articles nil))))) | 2784 | select-articles nil))))) |
| 2556 | (eq gnus-auto-select-next 'quietly)) | 2785 | (eq gnus-auto-select-next 'quietly)) |
| 2557 | (set-buffer gnus-group-buffer) | 2786 | (set-buffer gnus-group-buffer) |
| 2558 | ;; The entry function called above goes to the next | 2787 | ;; The entry function called above goes to the next |
| @@ -2634,6 +2863,7 @@ If NO-DISPLAY, don't generate a summary buffer." | |||
| 2634 | (gnus-summary-set-local-parameters gnus-newsgroup-name) | 2863 | (gnus-summary-set-local-parameters gnus-newsgroup-name) |
| 2635 | (gnus-update-format-specifications | 2864 | (gnus-update-format-specifications |
| 2636 | nil 'summary 'summary-mode 'summary-dummy) | 2865 | nil 'summary 'summary-mode 'summary-dummy) |
| 2866 | (gnus-update-summary-mark-positions) | ||
| 2637 | ;; Do score processing. | 2867 | ;; Do score processing. |
| 2638 | (when gnus-use-scoring | 2868 | (when gnus-use-scoring |
| 2639 | (gnus-possibly-score-headers)) | 2869 | (gnus-possibly-score-headers)) |
| @@ -2646,6 +2876,7 @@ If NO-DISPLAY, don't generate a summary buffer." | |||
| 2646 | (let ((gnus-newsgroup-dormant nil)) | 2876 | (let ((gnus-newsgroup-dormant nil)) |
| 2647 | (gnus-summary-initial-limit show-all)) | 2877 | (gnus-summary-initial-limit show-all)) |
| 2648 | (gnus-summary-initial-limit show-all)) | 2878 | (gnus-summary-initial-limit show-all)) |
| 2879 | ;; When untreaded, all articles are always shown. | ||
| 2649 | (setq gnus-newsgroup-limit | 2880 | (setq gnus-newsgroup-limit |
| 2650 | (mapcar | 2881 | (mapcar |
| 2651 | (lambda (header) (mail-header-number header)) | 2882 | (lambda (header) (mail-header-number header)) |
| @@ -2691,10 +2922,15 @@ If NO-DISPLAY, don't generate a summary buffer." | |||
| 2691 | (not no-display) | 2922 | (not no-display) |
| 2692 | gnus-newsgroup-unreads | 2923 | gnus-newsgroup-unreads |
| 2693 | gnus-auto-select-first) | 2924 | gnus-auto-select-first) |
| 2694 | (unless (if (eq gnus-auto-select-first 'best) | 2925 | (progn |
| 2695 | (gnus-summary-best-unread-article) | 2926 | (gnus-configure-windows 'summary) |
| 2696 | (gnus-summary-first-unread-article)) | 2927 | (cond |
| 2697 | (gnus-configure-windows 'summary)) | 2928 | ((eq gnus-auto-select-first 'best) |
| 2929 | (gnus-summary-best-unread-article)) | ||
| 2930 | ((eq gnus-auto-select-first t) | ||
| 2931 | (gnus-summary-first-unread-article)) | ||
| 2932 | ((gnus-functionp gnus-auto-select-first) | ||
| 2933 | (funcall gnus-auto-select-first)))) | ||
| 2698 | ;; Don't select any articles, just move point to the first | 2934 | ;; Don't select any articles, just move point to the first |
| 2699 | ;; article in the group. | 2935 | ;; article in the group. |
| 2700 | (goto-char (point-min)) | 2936 | (goto-char (point-min)) |
| @@ -2839,12 +3075,12 @@ If NO-DISPLAY, don't generate a summary buffer." | |||
| 2839 | result)) | 3075 | result)) |
| 2840 | 3076 | ||
| 2841 | (defun gnus-sort-gathered-threads (threads) | 3077 | (defun gnus-sort-gathered-threads (threads) |
| 2842 | "Sort subtreads inside each gathered thread by article number." | 3078 | "Sort subtreads inside each gathered thread by `gnus-sort-gathered-threads-function'." |
| 2843 | (let ((result threads)) | 3079 | (let ((result threads)) |
| 2844 | (while threads | 3080 | (while threads |
| 2845 | (when (stringp (caar threads)) | 3081 | (when (stringp (caar threads)) |
| 2846 | (setcdr (car threads) | 3082 | (setcdr (car threads) |
| 2847 | (sort (cdar threads) 'gnus-thread-sort-by-number))) | 3083 | (sort (cdar threads) gnus-sort-gathered-threads-function))) |
| 2848 | (setq threads (cdr threads))) | 3084 | (setq threads (cdr threads))) |
| 2849 | result)) | 3085 | result)) |
| 2850 | 3086 | ||
| @@ -2900,7 +3136,7 @@ If NO-DISPLAY, don't generate a summary buffer." | |||
| 2900 | threads)) | 3136 | threads)) |
| 2901 | 3137 | ||
| 2902 | ;; Build the thread tree. | 3138 | ;; Build the thread tree. |
| 2903 | (defun gnus-dependencies-add-header (header dependencies force-new) | 3139 | (defsubst gnus-dependencies-add-header (header dependencies force-new) |
| 2904 | "Enter HEADER into the DEPENDENCIES table if it is not already there. | 3140 | "Enter HEADER into the DEPENDENCIES table if it is not already there. |
| 2905 | 3141 | ||
| 2906 | If FORCE-NEW is not nil, enter HEADER into the DEPENDENCIES table even | 3142 | If FORCE-NEW is not nil, enter HEADER into the DEPENDENCIES table even |
| @@ -2979,6 +3215,7 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise." | |||
| 2979 | 3215 | ||
| 2980 | (defun gnus-build-sparse-threads () | 3216 | (defun gnus-build-sparse-threads () |
| 2981 | (let ((headers gnus-newsgroup-headers) | 3217 | (let ((headers gnus-newsgroup-headers) |
| 3218 | (mail-parse-charset gnus-newsgroup-charset) | ||
| 2982 | (gnus-summary-ignore-duplicates t) | 3219 | (gnus-summary-ignore-duplicates t) |
| 2983 | header references generation relations | 3220 | header references generation relations |
| 2984 | subject child end new-child date) | 3221 | subject child end new-child date) |
| @@ -3031,7 +3268,8 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise." | |||
| 3031 | ;; fetch the headers for the articles that aren't there. This will | 3268 | ;; fetch the headers for the articles that aren't there. This will |
| 3032 | ;; build complete threads - if the roots haven't been expired by the | 3269 | ;; build complete threads - if the roots haven't been expired by the |
| 3033 | ;; server, that is. | 3270 | ;; server, that is. |
| 3034 | (let (id heads) | 3271 | (let ((mail-parse-charset gnus-newsgroup-charset) |
| 3272 | id heads) | ||
| 3035 | (mapatoms | 3273 | (mapatoms |
| 3036 | (lambda (refs) | 3274 | (lambda (refs) |
| 3037 | (when (not (car (symbol-value refs))) | 3275 | (when (not (car (symbol-value refs))) |
| @@ -3046,24 +3284,6 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise." | |||
| 3046 | (setq heads nil))))) | 3284 | (setq heads nil))))) |
| 3047 | gnus-newsgroup-dependencies))) | 3285 | gnus-newsgroup-dependencies))) |
| 3048 | 3286 | ||
| 3049 | ;; The following macros and functions were written by Felix Lee | ||
| 3050 | ;; <flee@cse.psu.edu>. | ||
| 3051 | |||
| 3052 | (defmacro gnus-nov-read-integer () | ||
| 3053 | '(prog1 | ||
| 3054 | (if (= (following-char) ?\t) | ||
| 3055 | 0 | ||
| 3056 | (let ((num (ignore-errors (read buffer)))) | ||
| 3057 | (if (numberp num) num 0))) | ||
| 3058 | (unless (eobp) | ||
| 3059 | (search-forward "\t" eol 'move)))) | ||
| 3060 | |||
| 3061 | (defmacro gnus-nov-skip-field () | ||
| 3062 | '(search-forward "\t" eol 'move)) | ||
| 3063 | |||
| 3064 | (defmacro gnus-nov-field () | ||
| 3065 | '(buffer-substring (point) (if (gnus-nov-skip-field) (1- (point)) eol))) | ||
| 3066 | |||
| 3067 | ;; This function has to be called with point after the article number | 3287 | ;; This function has to be called with point after the article number |
| 3068 | ;; on the beginning of the line. | 3288 | ;; on the beginning of the line. |
| 3069 | (defsubst gnus-nov-parse-line (number dependencies &optional force-new) | 3289 | (defsubst gnus-nov-parse-line (number dependencies &optional force-new) |
| @@ -3081,18 +3301,20 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise." | |||
| 3081 | (setq header | 3301 | (setq header |
| 3082 | (make-full-mail-header | 3302 | (make-full-mail-header |
| 3083 | number ; number | 3303 | number ; number |
| 3084 | (funcall | 3304 | (funcall gnus-decode-encoded-word-function |
| 3085 | gnus-unstructured-field-decoder (gnus-nov-field)) ; subject | 3305 | (nnheader-nov-field)) ; subject |
| 3086 | (funcall | 3306 | (funcall gnus-decode-encoded-word-function |
| 3087 | gnus-structured-field-decoder (gnus-nov-field)) ; from | 3307 | (nnheader-nov-field)) ; from |
| 3088 | (gnus-nov-field) ; date | 3308 | (nnheader-nov-field) ; date |
| 3089 | (or (gnus-nov-field) | 3309 | (nnheader-nov-read-message-id) ; id |
| 3090 | (nnheader-generate-fake-message-id)) ; id | 3310 | (nnheader-nov-field) ; refs |
| 3091 | (gnus-nov-field) ; refs | 3311 | (nnheader-nov-read-integer) ; chars |
| 3092 | (gnus-nov-read-integer) ; chars | 3312 | (nnheader-nov-read-integer) ; lines |
| 3093 | (gnus-nov-read-integer) ; lines | 3313 | (unless (eobp) |
| 3094 | (unless (= (following-char) ?\n) | 3314 | (if (looking-at "Xref: ") |
| 3095 | (gnus-nov-field))))) ; misc | 3315 | (goto-char (match-end 0))) |
| 3316 | (nnheader-nov-field)) ; Xref | ||
| 3317 | (nnheader-nov-parse-extra)))) ; extra | ||
| 3096 | 3318 | ||
| 3097 | (widen)) | 3319 | (widen)) |
| 3098 | 3320 | ||
| @@ -3101,9 +3323,9 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise." | |||
| 3101 | (gnus-dependencies-add-header header dependencies force-new))) | 3323 | (gnus-dependencies-add-header header dependencies force-new))) |
| 3102 | 3324 | ||
| 3103 | (defun gnus-build-get-header (id) | 3325 | (defun gnus-build-get-header (id) |
| 3104 | ;; Look through the buffer of NOV lines and find the header to | 3326 | "Look through the buffer of NOV lines and find the header to ID. |
| 3105 | ;; ID. Enter this line into the dependencies hash table, and return | 3327 | Enter this line into the dependencies hash table, and return |
| 3106 | ;; the id of the parent article (if any). | 3328 | the id of the parent article (if any)." |
| 3107 | (let ((deps gnus-newsgroup-dependencies) | 3329 | (let ((deps gnus-newsgroup-dependencies) |
| 3108 | found header) | 3330 | found header) |
| 3109 | (prog1 | 3331 | (prog1 |
| @@ -3138,6 +3360,7 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise." | |||
| 3138 | (defun gnus-build-all-threads () | 3360 | (defun gnus-build-all-threads () |
| 3139 | "Read all the headers." | 3361 | "Read all the headers." |
| 3140 | (let ((gnus-summary-ignore-duplicates t) | 3362 | (let ((gnus-summary-ignore-duplicates t) |
| 3363 | (mail-parse-charset gnus-newsgroup-charset) | ||
| 3141 | (dependencies gnus-newsgroup-dependencies) | 3364 | (dependencies gnus-newsgroup-dependencies) |
| 3142 | header article) | 3365 | header article) |
| 3143 | (save-excursion | 3366 | (save-excursion |
| @@ -3147,8 +3370,7 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise." | |||
| 3147 | (while (not (eobp)) | 3370 | (while (not (eobp)) |
| 3148 | (ignore-errors | 3371 | (ignore-errors |
| 3149 | (setq article (read (current-buffer)) | 3372 | (setq article (read (current-buffer)) |
| 3150 | header (gnus-nov-parse-line | 3373 | header (gnus-nov-parse-line article dependencies))) |
| 3151 | article dependencies))) | ||
| 3152 | (when header | 3374 | (when header |
| 3153 | (save-excursion | 3375 | (save-excursion |
| 3154 | (set-buffer gnus-summary-buffer) | 3376 | (set-buffer gnus-summary-buffer) |
| @@ -3185,17 +3407,19 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise." | |||
| 3185 | (memq article gnus-newsgroup-expirable) | 3407 | (memq article gnus-newsgroup-expirable) |
| 3186 | ;; Only insert the Subject string when it's different | 3408 | ;; Only insert the Subject string when it's different |
| 3187 | ;; from the previous Subject string. | 3409 | ;; from the previous Subject string. |
| 3188 | (if (gnus-subject-equal | 3410 | (if (and |
| 3189 | (condition-case () | 3411 | gnus-show-threads |
| 3190 | (mail-header-subject | 3412 | (gnus-subject-equal |
| 3191 | (gnus-data-header | 3413 | (condition-case () |
| 3192 | (cadr | 3414 | (mail-header-subject |
| 3193 | (gnus-data-find-list | 3415 | (gnus-data-header |
| 3194 | article | 3416 | (cadr |
| 3195 | (gnus-data-list t))))) | 3417 | (gnus-data-find-list |
| 3196 | ;; Error on the side of excessive subjects. | 3418 | article |
| 3197 | (error "")) | 3419 | (gnus-data-list t))))) |
| 3198 | (mail-header-subject header)) | 3420 | ;; Error on the side of excessive subjects. |
| 3421 | (error "")) | ||
| 3422 | (mail-header-subject header))) | ||
| 3199 | "" | 3423 | "" |
| 3200 | (mail-header-subject header)) | 3424 | (mail-header-subject header)) |
| 3201 | nil (cdr (assq article gnus-newsgroup-scored)) | 3425 | nil (cdr (assq article gnus-newsgroup-scored)) |
| @@ -3409,7 +3633,6 @@ If LINE, insert the rebuilt thread starting on line LINE." | |||
| 3409 | (while thread | 3633 | (while thread |
| 3410 | (gnus-remove-thread-1 (car thread)) | 3634 | (gnus-remove-thread-1 (car thread)) |
| 3411 | (setq thread (cdr thread)))) | 3635 | (setq thread (cdr thread)))) |
| 3412 | (gnus-summary-show-all-threads) | ||
| 3413 | (gnus-remove-thread-1 thread)))))))) | 3636 | (gnus-remove-thread-1 thread)))))))) |
| 3414 | 3637 | ||
| 3415 | (defun gnus-remove-thread-1 (thread) | 3638 | (defun gnus-remove-thread-1 (thread) |
| @@ -3421,6 +3644,7 @@ If LINE, insert the rebuilt thread starting on line LINE." | |||
| 3421 | (gnus-remove-thread-1 (pop thread))) | 3644 | (gnus-remove-thread-1 (pop thread))) |
| 3422 | (when (setq d (gnus-data-find number)) | 3645 | (when (setq d (gnus-data-find number)) |
| 3423 | (goto-char (gnus-data-pos d)) | 3646 | (goto-char (gnus-data-pos d)) |
| 3647 | (gnus-summary-show-thread) | ||
| 3424 | (gnus-data-remove | 3648 | (gnus-data-remove |
| 3425 | number | 3649 | number |
| 3426 | (- (gnus-point-at-bol) | 3650 | (- (gnus-point-at-bol) |
| @@ -3428,13 +3652,22 @@ If LINE, insert the rebuilt thread starting on line LINE." | |||
| 3428 | (1+ (gnus-point-at-eol)) | 3652 | (1+ (gnus-point-at-eol)) |
| 3429 | (gnus-delete-line))))))) | 3653 | (gnus-delete-line))))))) |
| 3430 | 3654 | ||
| 3655 | (defun gnus-sort-threads-1 (threads func) | ||
| 3656 | (sort (mapcar (lambda (thread) | ||
| 3657 | (cons (car thread) | ||
| 3658 | (and (cdr thread) | ||
| 3659 | (gnus-sort-threads-1 (cdr thread) func)))) | ||
| 3660 | threads) func)) | ||
| 3661 | |||
| 3431 | (defun gnus-sort-threads (threads) | 3662 | (defun gnus-sort-threads (threads) |
| 3432 | "Sort THREADS." | 3663 | "Sort THREADS." |
| 3433 | (if (not gnus-thread-sort-functions) | 3664 | (if (not gnus-thread-sort-functions) |
| 3434 | threads | 3665 | threads |
| 3435 | (gnus-message 8 "Sorting threads...") | 3666 | (gnus-message 8 "Sorting threads...") |
| 3436 | (prog1 | 3667 | (prog1 |
| 3437 | (sort threads (gnus-make-sort-function gnus-thread-sort-functions)) | 3668 | (gnus-sort-threads-1 |
| 3669 | threads | ||
| 3670 | (gnus-make-sort-function gnus-thread-sort-functions)) | ||
| 3438 | (gnus-message 8 "Sorting threads...done")))) | 3671 | (gnus-message 8 "Sorting threads...done")))) |
| 3439 | 3672 | ||
| 3440 | (defun gnus-sort-articles (articles) | 3673 | (defun gnus-sort-articles (articles) |
| @@ -3449,12 +3682,12 @@ If LINE, insert the rebuilt thread starting on line LINE." | |||
| 3449 | 3682 | ||
| 3450 | ;; Written by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>. | 3683 | ;; Written by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>. |
| 3451 | (defmacro gnus-thread-header (thread) | 3684 | (defmacro gnus-thread-header (thread) |
| 3452 | ;; Return header of first article in THREAD. | 3685 | "Return header of first article in THREAD. |
| 3453 | ;; Note that THREAD must never, ever be anything else than a variable - | 3686 | Note that THREAD must never, ever be anything else than a variable - |
| 3454 | ;; using some other form will lead to serious barfage. | 3687 | using some other form will lead to serious barfage." |
| 3455 | (or (symbolp thread) (signal 'wrong-type-argument '(symbolp thread))) | 3688 | (or (symbolp thread) (signal 'wrong-type-argument '(symbolp thread))) |
| 3456 | ;; (8% speedup to gnus-summary-prepare, just for fun :-) | 3689 | ;; (8% speedup to gnus-summary-prepare, just for fun :-) |
| 3457 | (list 'byte-code "\10\211:\203\17\0\211@;\203\16\0A@@\207" ; | 3690 | (list 'byte-code "\10\211:\203\17\0\211@;\203\16\0A@@\207" |
| 3458 | (vector thread) 2)) | 3691 | (vector thread) 2)) |
| 3459 | 3692 | ||
| 3460 | (defsubst gnus-article-sort-by-number (h1 h2) | 3693 | (defsubst gnus-article-sort-by-number (h1 h2) |
| @@ -3477,6 +3710,16 @@ If LINE, insert the rebuilt thread starting on line LINE." | |||
| 3477 | (gnus-article-sort-by-lines | 3710 | (gnus-article-sort-by-lines |
| 3478 | (gnus-thread-header h1) (gnus-thread-header h2))) | 3711 | (gnus-thread-header h1) (gnus-thread-header h2))) |
| 3479 | 3712 | ||
| 3713 | (defsubst gnus-article-sort-by-chars (h1 h2) | ||
| 3714 | "Sort articles by octet length." | ||
| 3715 | (< (mail-header-chars h1) | ||
| 3716 | (mail-header-chars h2))) | ||
| 3717 | |||
| 3718 | (defun gnus-thread-sort-by-chars (h1 h2) | ||
| 3719 | "Sort threads by root article octet length." | ||
| 3720 | (gnus-article-sort-by-chars | ||
| 3721 | (gnus-thread-header h1) (gnus-thread-header h2))) | ||
| 3722 | |||
| 3480 | (defsubst gnus-article-sort-by-author (h1 h2) | 3723 | (defsubst gnus-article-sort-by-author (h1 h2) |
| 3481 | "Sort articles by root author." | 3724 | "Sort articles by root author." |
| 3482 | (string-lessp | 3725 | (string-lessp |
| @@ -3507,7 +3750,7 @@ If LINE, insert the rebuilt thread starting on line LINE." | |||
| 3507 | 3750 | ||
| 3508 | (defsubst gnus-article-sort-by-date (h1 h2) | 3751 | (defsubst gnus-article-sort-by-date (h1 h2) |
| 3509 | "Sort articles by root article date." | 3752 | "Sort articles by root article date." |
| 3510 | (gnus-time-less | 3753 | (time-less-p |
| 3511 | (gnus-date-get-time (mail-header-date h1)) | 3754 | (gnus-date-get-time (mail-header-date h1)) |
| 3512 | (gnus-date-get-time (mail-header-date h2)))) | 3755 | (gnus-date-get-time (mail-header-date h2)))) |
| 3513 | 3756 | ||
| @@ -3537,7 +3780,7 @@ Unscored articles will be counted as having a score of zero." | |||
| 3537 | (> (gnus-thread-total-score h1) (gnus-thread-total-score h2))) | 3780 | (> (gnus-thread-total-score h1) (gnus-thread-total-score h2))) |
| 3538 | 3781 | ||
| 3539 | (defun gnus-thread-total-score (thread) | 3782 | (defun gnus-thread-total-score (thread) |
| 3540 | ;; This function find the total score of THREAD. | 3783 | ;; This function find the total score of THREAD. |
| 3541 | (cond ((null thread) | 3784 | (cond ((null thread) |
| 3542 | 0) | 3785 | 0) |
| 3543 | ((consp thread) | 3786 | ((consp thread) |
| @@ -3568,6 +3811,12 @@ Unscored articles will be counted as having a score of zero." | |||
| 3568 | (defvar gnus-tmp-root-expunged nil) | 3811 | (defvar gnus-tmp-root-expunged nil) |
| 3569 | (defvar gnus-tmp-dummy-line nil) | 3812 | (defvar gnus-tmp-dummy-line nil) |
| 3570 | 3813 | ||
| 3814 | (defvar gnus-tmp-header) | ||
| 3815 | (defun gnus-extra-header (type &optional header) | ||
| 3816 | "Return the extra header of TYPE." | ||
| 3817 | (or (cdr (assq type (mail-header-extra (or header gnus-tmp-header)))) | ||
| 3818 | "")) | ||
| 3819 | |||
| 3571 | (defun gnus-summary-prepare-threads (threads) | 3820 | (defun gnus-summary-prepare-threads (threads) |
| 3572 | "Prepare summary buffer from THREADS and indentation LEVEL. | 3821 | "Prepare summary buffer from THREADS and indentation LEVEL. |
| 3573 | THREADS is either a list of `(PARENT [(CHILD1 [(GRANDCHILD ...]...) ...])' | 3822 | THREADS is either a list of `(PARENT [(CHILD1 [(GRANDCHILD ...]...) ...])' |
| @@ -3765,7 +4014,7 @@ or a straight list of headers." | |||
| 3765 | (if (or (null gnus-summary-default-score) | 4014 | (if (or (null gnus-summary-default-score) |
| 3766 | (<= (abs (- gnus-tmp-score gnus-summary-default-score)) | 4015 | (<= (abs (- gnus-tmp-score gnus-summary-default-score)) |
| 3767 | gnus-summary-zcore-fuzz)) | 4016 | gnus-summary-zcore-fuzz)) |
| 3768 | ? ;space | 4017 | ? ;Whitespace |
| 3769 | (if (< gnus-tmp-score gnus-summary-default-score) | 4018 | (if (< gnus-tmp-score gnus-summary-default-score) |
| 3770 | gnus-score-below-mark gnus-score-over-mark)) | 4019 | gnus-score-below-mark gnus-score-over-mark)) |
| 3771 | gnus-tmp-replied | 4020 | gnus-tmp-replied |
| @@ -3795,7 +4044,7 @@ or a straight list of headers." | |||
| 3795 | (setq gnus-tmp-name gnus-tmp-from)) | 4044 | (setq gnus-tmp-name gnus-tmp-from)) |
| 3796 | (unless (numberp gnus-tmp-lines) | 4045 | (unless (numberp gnus-tmp-lines) |
| 3797 | (setq gnus-tmp-lines 0)) | 4046 | (setq gnus-tmp-lines 0)) |
| 3798 | (gnus-put-text-property-excluding-characters-with-faces | 4047 | (gnus-put-text-property |
| 3799 | (point) | 4048 | (point) |
| 3800 | (progn (eval gnus-summary-line-format-spec) (point)) | 4049 | (progn (eval gnus-summary-line-format-spec) (point)) |
| 3801 | 'gnus-number number) | 4050 | 'gnus-number number) |
| @@ -3849,6 +4098,24 @@ or a straight list of headers." | |||
| 3849 | (cdr (assq number gnus-newsgroup-scored)) | 4098 | (cdr (assq number gnus-newsgroup-scored)) |
| 3850 | (memq number gnus-newsgroup-processable)))))) | 4099 | (memq number gnus-newsgroup-processable)))))) |
| 3851 | 4100 | ||
| 4101 | (defun gnus-summary-remove-list-identifiers () | ||
| 4102 | "Remove list identifiers in `gnus-list-identifiers' from articles in the current group." | ||
| 4103 | (let ((regexp (if (stringp gnus-list-identifiers) | ||
| 4104 | gnus-list-identifiers | ||
| 4105 | (mapconcat 'identity gnus-list-identifiers " *\\|")))) | ||
| 4106 | (dolist (header gnus-newsgroup-headers) | ||
| 4107 | (when (string-match (concat "\\(\\(\\(Re: +\\)?\\(" regexp | ||
| 4108 | " *\\)\\)+\\(Re: +\\)?\\)") | ||
| 4109 | (mail-header-subject header)) | ||
| 4110 | (mail-header-set-subject | ||
| 4111 | header (concat (substring (mail-header-subject header) | ||
| 4112 | 0 (match-beginning 1)) | ||
| 4113 | (or | ||
| 4114 | (match-string 3 (mail-header-subject header)) | ||
| 4115 | (match-string 5 (mail-header-subject header))) | ||
| 4116 | (substring (mail-header-subject header) | ||
| 4117 | (match-end 1)))))))) | ||
| 4118 | |||
| 3852 | (defun gnus-select-newsgroup (group &optional read-all select-articles) | 4119 | (defun gnus-select-newsgroup (group &optional read-all select-articles) |
| 3853 | "Select newsgroup GROUP. | 4120 | "Select newsgroup GROUP. |
| 3854 | If READ-ALL is non-nil, all articles in the group are selected. | 4121 | If READ-ALL is non-nil, all articles in the group are selected. |
| @@ -3884,6 +4151,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." | |||
| 3884 | (setq gnus-newsgroup-name group) | 4151 | (setq gnus-newsgroup-name group) |
| 3885 | (setq gnus-newsgroup-unselected nil) | 4152 | (setq gnus-newsgroup-unselected nil) |
| 3886 | (setq gnus-newsgroup-unreads (gnus-list-of-unread-articles group)) | 4153 | (setq gnus-newsgroup-unreads (gnus-list-of-unread-articles group)) |
| 4154 | (gnus-summary-setup-default-charset) | ||
| 3887 | 4155 | ||
| 3888 | ;; Adjust and set lists of article marks. | 4156 | ;; Adjust and set lists of article marks. |
| 3889 | (when info | 4157 | (when info |
| @@ -3918,6 +4186,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." | |||
| 3918 | ;; Init the dependencies hash table. | 4186 | ;; Init the dependencies hash table. |
| 3919 | (setq gnus-newsgroup-dependencies | 4187 | (setq gnus-newsgroup-dependencies |
| 3920 | (gnus-make-hashtable (length articles))) | 4188 | (gnus-make-hashtable (length articles))) |
| 4189 | (gnus-set-global-variables) | ||
| 3921 | ;; Retrieve the headers and read them in. | 4190 | ;; Retrieve the headers and read them in. |
| 3922 | (gnus-message 5 "Fetching headers for %s..." gnus-newsgroup-name) | 4191 | (gnus-message 5 "Fetching headers for %s..." gnus-newsgroup-name) |
| 3923 | (setq gnus-newsgroup-headers | 4192 | (setq gnus-newsgroup-headers |
| @@ -3966,6 +4235,9 @@ If SELECT-ARTICLES, only select those articles from GROUP." | |||
| 3966 | ;; Let the Gnus agent mark articles as read. | 4235 | ;; Let the Gnus agent mark articles as read. |
| 3967 | (when gnus-agent | 4236 | (when gnus-agent |
| 3968 | (gnus-agent-get-undownloaded-list)) | 4237 | (gnus-agent-get-undownloaded-list)) |
| 4238 | ;; Remove list identifiers from subject | ||
| 4239 | (when gnus-list-identifiers | ||
| 4240 | (gnus-summary-remove-list-identifiers)) | ||
| 3969 | ;; Check whether auto-expire is to be done in this group. | 4241 | ;; Check whether auto-expire is to be done in this group. |
| 3970 | (setq gnus-newsgroup-auto-expire | 4242 | (setq gnus-newsgroup-auto-expire |
| 3971 | (gnus-group-auto-expirable-p group)) | 4243 | (gnus-group-auto-expirable-p group)) |
| @@ -3983,7 +4255,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." | |||
| 3983 | (or gnus-newsgroup-headers t))))) | 4255 | (or gnus-newsgroup-headers t))))) |
| 3984 | 4256 | ||
| 3985 | (defun gnus-articles-to-read (group &optional read-all) | 4257 | (defun gnus-articles-to-read (group &optional read-all) |
| 3986 | ;; Find out what articles the user wants to read. | 4258 | "Find out what articles the user wants to read." |
| 3987 | (let* ((articles | 4259 | (let* ((articles |
| 3988 | ;; Select all articles if `read-all' is non-nil, or if there | 4260 | ;; Select all articles if `read-all' is non-nil, or if there |
| 3989 | ;; are no unread articles. | 4261 | ;; are no unread articles. |
| @@ -3992,7 +4264,9 @@ If SELECT-ARTICLES, only select those articles from GROUP." | |||
| 3992 | (zerop (length gnus-newsgroup-unreads))) | 4264 | (zerop (length gnus-newsgroup-unreads))) |
| 3993 | (eq (gnus-group-find-parameter group 'display) | 4265 | (eq (gnus-group-find-parameter group 'display) |
| 3994 | 'all)) | 4266 | 'all)) |
| 3995 | (gnus-uncompress-range (gnus-active group)) | 4267 | (or |
| 4268 | (gnus-uncompress-range (gnus-active group)) | ||
| 4269 | (gnus-cache-articles-in-group group)) | ||
| 3996 | (sort (append gnus-newsgroup-dormant gnus-newsgroup-marked | 4270 | (sort (append gnus-newsgroup-dormant gnus-newsgroup-marked |
| 3997 | (copy-sequence gnus-newsgroup-unreads)) | 4271 | (copy-sequence gnus-newsgroup-unreads)) |
| 3998 | '<))) | 4272 | '<))) |
| @@ -4048,6 +4322,12 @@ If SELECT-ARTICLES, only select those articles from GROUP." | |||
| 4048 | (gnus-sorted-intersection | 4322 | (gnus-sorted-intersection |
| 4049 | gnus-newsgroup-unreads | 4323 | gnus-newsgroup-unreads |
| 4050 | (gnus-sorted-complement gnus-newsgroup-unreads articles))) | 4324 | (gnus-sorted-complement gnus-newsgroup-unreads articles))) |
| 4325 | (when gnus-alter-articles-to-read-function | ||
| 4326 | (setq gnus-newsgroup-unreads | ||
| 4327 | (sort | ||
| 4328 | (funcall gnus-alter-articles-to-read-function | ||
| 4329 | gnus-newsgroup-name gnus-newsgroup-unreads) | ||
| 4330 | '<))) | ||
| 4051 | articles))) | 4331 | articles))) |
| 4052 | 4332 | ||
| 4053 | (defun gnus-killed-articles (killed articles) | 4333 | (defun gnus-killed-articles (killed articles) |
| @@ -4070,7 +4350,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." | |||
| 4070 | out)) | 4350 | out)) |
| 4071 | 4351 | ||
| 4072 | (defun gnus-adjust-marked-articles (info) | 4352 | (defun gnus-adjust-marked-articles (info) |
| 4073 | "Set all article lists and remove all marks that are no longer legal." | 4353 | "Set all article lists and remove all marks that are no longer valid." |
| 4074 | (let* ((marked-lists (gnus-info-marks info)) | 4354 | (let* ((marked-lists (gnus-info-marks info)) |
| 4075 | (active (gnus-active (gnus-info-group info))) | 4355 | (active (gnus-active (gnus-info-group info))) |
| 4076 | (min (car active)) | 4356 | (min (car active)) |
| @@ -4128,15 +4408,16 @@ If SELECT-ARTICLES, only select those articles from GROUP." | |||
| 4128 | (let ((types gnus-article-mark-lists) | 4408 | (let ((types gnus-article-mark-lists) |
| 4129 | (info (gnus-get-info gnus-newsgroup-name)) | 4409 | (info (gnus-get-info gnus-newsgroup-name)) |
| 4130 | (uncompressed '(score bookmark killed)) | 4410 | (uncompressed '(score bookmark killed)) |
| 4131 | type list newmarked symbol) | 4411 | type list newmarked symbol delta-marks) |
| 4132 | (when info | 4412 | (when info |
| 4133 | ;; Add all marks lists that are non-nil to the list of marks lists. | 4413 | ;; Add all marks lists to the list of marks lists. |
| 4134 | (while (setq type (pop types)) | 4414 | (while (setq type (pop types)) |
| 4135 | (when (setq list (symbol-value | 4415 | (setq list (symbol-value |
| 4136 | (setq symbol | 4416 | (setq symbol |
| 4137 | (intern (format "gnus-newsgroup-%s" | 4417 | (intern (format "gnus-newsgroup-%s" |
| 4138 | (car type)))))) | 4418 | (car type)))))) |
| 4139 | 4419 | ||
| 4420 | (when list | ||
| 4140 | ;; Get rid of the entries of the articles that have the | 4421 | ;; Get rid of the entries of the articles that have the |
| 4141 | ;; default score. | 4422 | ;; default score. |
| 4142 | (when (and (eq (cdr type) 'score) | 4423 | (when (and (eq (cdr type) 'score) |
| @@ -4151,14 +4432,38 @@ If SELECT-ARTICLES, only select those articles from GROUP." | |||
| 4151 | (setcdr prev (cdr arts)) | 4432 | (setcdr prev (cdr arts)) |
| 4152 | (setq prev arts)) | 4433 | (setq prev arts)) |
| 4153 | (setq arts (cdr arts))) | 4434 | (setq arts (cdr arts))) |
| 4154 | (setq list (cdr all)))) | 4435 | (setq list (cdr all))))) |
| 4155 | 4436 | ||
| 4156 | (push (cons (cdr type) | 4437 | (unless (memq (cdr type) uncompressed) |
| 4157 | (if (memq (cdr type) uncompressed) list | 4438 | (setq list (gnus-compress-sequence (set symbol (sort list '<)) t))) |
| 4158 | (gnus-compress-sequence | 4439 | |
| 4159 | (set symbol (sort list '<)) t))) | 4440 | (when (gnus-check-backend-function |
| 4160 | newmarked))) | 4441 | 'request-set-mark gnus-newsgroup-name) |
| 4161 | 4442 | ;; propagate flags to server, with the following exceptions: | |
| 4443 | ;; uncompressed:s are not proper flags (they are cons cells) | ||
| 4444 | ;; cache is a internal gnus flag | ||
| 4445 | ;; download are local to one gnus installation (well) | ||
| 4446 | ;; unsend are for nndraft groups only | ||
| 4447 | ;; xxx: generality of this? this suits nnimap anyway | ||
| 4448 | (unless (memq (cdr type) (append '(cache download unsend) | ||
| 4449 | uncompressed)) | ||
| 4450 | (let* ((old (cdr (assq (cdr type) (gnus-info-marks info)))) | ||
| 4451 | (del (gnus-remove-from-range (gnus-copy-sequence old) list)) | ||
| 4452 | (add (gnus-remove-from-range | ||
| 4453 | (gnus-copy-sequence list) old))) | ||
| 4454 | (when add | ||
| 4455 | (push (list add 'add (list (cdr type))) delta-marks)) | ||
| 4456 | (when del | ||
| 4457 | (push (list del 'del (list (cdr type))) delta-marks))))) | ||
| 4458 | |||
| 4459 | (when list | ||
| 4460 | (push (cons (cdr type) list) newmarked))) | ||
| 4461 | |||
| 4462 | (when delta-marks | ||
| 4463 | (unless (gnus-check-group gnus-newsgroup-name) | ||
| 4464 | (error "Can't open server for %s" gnus-newsgroup-name)) | ||
| 4465 | (gnus-request-set-mark gnus-newsgroup-name delta-marks)) | ||
| 4466 | |||
| 4162 | ;; Enter these new marks into the info of the group. | 4467 | ;; Enter these new marks into the info of the group. |
| 4163 | (if (nthcdr 3 info) | 4468 | (if (nthcdr 3 info) |
| 4164 | (setcar (nthcdr 3 info) newmarked) | 4469 | (setcar (nthcdr 3 info) newmarked) |
| @@ -4174,10 +4479,12 @@ If SELECT-ARTICLES, only select those articles from GROUP." | |||
| 4174 | (setcdr (nthcdr i info) nil))))))) | 4479 | (setcdr (nthcdr i info) nil))))))) |
| 4175 | 4480 | ||
| 4176 | (defun gnus-set-mode-line (where) | 4481 | (defun gnus-set-mode-line (where) |
| 4177 | "This function sets the mode line of the article or summary buffers. | 4482 | "Set the mode line of the article or summary buffers. |
| 4178 | If WHERE is `summary', the summary mode line format will be used." | 4483 | If WHERE is `summary', the summary mode line format will be used." |
| 4179 | ;; Is this mode line one we keep updated? | 4484 | ;; Is this mode line one we keep updated? |
| 4180 | (when (memq where gnus-updated-mode-lines) | 4485 | (when (and (memq where gnus-updated-mode-lines) |
| 4486 | (symbol-value | ||
| 4487 | (intern (format "gnus-%s-mode-line-format-spec" where)))) | ||
| 4181 | (let (mode-string) | 4488 | (let (mode-string) |
| 4182 | (save-excursion | 4489 | (save-excursion |
| 4183 | ;; We evaluate this in the summary buffer since these | 4490 | ;; We evaluate this in the summary buffer since these |
| @@ -4188,7 +4495,11 @@ If WHERE is `summary', the summary mode line format will be used." | |||
| 4188 | (let* ((mformat (symbol-value | 4495 | (let* ((mformat (symbol-value |
| 4189 | (intern | 4496 | (intern |
| 4190 | (format "gnus-%s-mode-line-format-spec" where)))) | 4497 | (format "gnus-%s-mode-line-format-spec" where)))) |
| 4191 | (gnus-tmp-group-name gnus-newsgroup-name) | 4498 | (gnus-tmp-group-name (gnus-group-name-decode |
| 4499 | gnus-newsgroup-name | ||
| 4500 | (gnus-group-name-charset | ||
| 4501 | nil | ||
| 4502 | gnus-newsgroup-name))) | ||
| 4192 | (gnus-tmp-article-number (or gnus-current-article 0)) | 4503 | (gnus-tmp-article-number (or gnus-current-article 0)) |
| 4193 | (gnus-tmp-unread gnus-newsgroup-unreads) | 4504 | (gnus-tmp-unread gnus-newsgroup-unreads) |
| 4194 | (gnus-tmp-unread-and-unticked (length gnus-newsgroup-unreads)) | 4505 | (gnus-tmp-unread-and-unticked (length gnus-newsgroup-unreads)) |
| @@ -4227,7 +4538,7 @@ If WHERE is `summary', the summary mode line format will be used." | |||
| 4227 | ;; We might have to chop a bit of the string off... | 4538 | ;; We might have to chop a bit of the string off... |
| 4228 | (when (> (length mode-string) max-len) | 4539 | (when (> (length mode-string) max-len) |
| 4229 | (setq mode-string | 4540 | (setq mode-string |
| 4230 | (concat (gnus-truncate-string mode-string (- max-len 3)) | 4541 | (concat (truncate-string-to-width mode-string (- max-len 3)) |
| 4231 | "..."))) | 4542 | "..."))) |
| 4232 | ;; Pad the mode string a bit. | 4543 | ;; Pad the mode string a bit. |
| 4233 | (setq mode-string (format (format "%%-%ds" max-len) mode-string)))) | 4544 | (setq mode-string (format (format "%%-%ds" max-len) mode-string)))) |
| @@ -4305,7 +4616,7 @@ The resulting hash table is returned, or nil if no Xrefs were found." | |||
| 4305 | (active (gnus-active group)) | 4616 | (active (gnus-active group)) |
| 4306 | ninfo) | 4617 | ninfo) |
| 4307 | (when entry | 4618 | (when entry |
| 4308 | ;; First peel off all illegal article numbers. | 4619 | ;; First peel off all invalid article numbers. |
| 4309 | (when active | 4620 | (when active |
| 4310 | (let ((ids articles) | 4621 | (let ((ids articles) |
| 4311 | id first) | 4622 | id first) |
| @@ -4374,15 +4685,6 @@ The resulting hash table is returned, or nil if no Xrefs were found." | |||
| 4374 | ;; Update the group buffer. | 4685 | ;; Update the group buffer. |
| 4375 | (gnus-group-update-group group t))))) | 4686 | (gnus-group-update-group group t))))) |
| 4376 | 4687 | ||
| 4377 | (defun gnus-methods-equal-p (m1 m2) | ||
| 4378 | (let ((m1 (or m1 gnus-select-method)) | ||
| 4379 | (m2 (or m2 gnus-select-method))) | ||
| 4380 | (or (equal m1 m2) | ||
| 4381 | (and (eq (car m1) (car m2)) | ||
| 4382 | (or (not (memq 'address (assoc (symbol-name (car m1)) | ||
| 4383 | gnus-valid-select-methods))) | ||
| 4384 | (equal (nth 1 m1) (nth 1 m2))))))) | ||
| 4385 | |||
| 4386 | (defvar gnus-newsgroup-none-id 0) | 4688 | (defvar gnus-newsgroup-none-id 0) |
| 4387 | 4689 | ||
| 4388 | (defun gnus-get-newsgroup-headers (&optional dependencies force-new) | 4690 | (defun gnus-get-newsgroup-headers (&optional dependencies force-new) |
| @@ -4391,11 +4693,18 @@ The resulting hash table is returned, or nil if no Xrefs were found." | |||
| 4391 | (or dependencies | 4693 | (or dependencies |
| 4392 | (save-excursion (set-buffer gnus-summary-buffer) | 4694 | (save-excursion (set-buffer gnus-summary-buffer) |
| 4393 | gnus-newsgroup-dependencies))) | 4695 | gnus-newsgroup-dependencies))) |
| 4394 | headers id end ref) | 4696 | headers id end ref |
| 4697 | (mail-parse-charset gnus-newsgroup-charset) | ||
| 4698 | (mail-parse-ignored-charsets | ||
| 4699 | (save-excursion (condition-case nil | ||
| 4700 | (set-buffer gnus-summary-buffer) | ||
| 4701 | (error)) | ||
| 4702 | gnus-newsgroup-ignored-charsets))) | ||
| 4395 | (save-excursion | 4703 | (save-excursion |
| 4396 | (set-buffer nntp-server-buffer) | 4704 | (set-buffer nntp-server-buffer) |
| 4397 | ;; Translate all TAB characters into SPACE characters. | 4705 | ;; Translate all TAB characters into SPACE characters. |
| 4398 | (subst-char-in-region (point-min) (point-max) ?\t ? t) | 4706 | (subst-char-in-region (point-min) (point-max) ?\t ? t) |
| 4707 | (subst-char-in-region (point-min) (point-max) ?\r ? t) | ||
| 4399 | (gnus-run-hooks 'gnus-parse-headers-hook) | 4708 | (gnus-run-hooks 'gnus-parse-headers-hook) |
| 4400 | (let ((case-fold-search t) | 4709 | (let ((case-fold-search t) |
| 4401 | in-reply-to header p lines chars) | 4710 | in-reply-to header p lines chars) |
| @@ -4427,15 +4736,15 @@ The resulting hash table is returned, or nil if no Xrefs were found." | |||
| 4427 | (progn | 4736 | (progn |
| 4428 | (goto-char p) | 4737 | (goto-char p) |
| 4429 | (if (search-forward "\nsubject: " nil t) | 4738 | (if (search-forward "\nsubject: " nil t) |
| 4430 | (funcall | 4739 | (funcall gnus-decode-encoded-word-function |
| 4431 | gnus-unstructured-field-decoder (nnheader-header-value)) | 4740 | (nnheader-header-value)) |
| 4432 | "(none)")) | 4741 | "(none)")) |
| 4433 | ;; From. | 4742 | ;; From. |
| 4434 | (progn | 4743 | (progn |
| 4435 | (goto-char p) | 4744 | (goto-char p) |
| 4436 | (if (search-forward "\nfrom: " nil t) | 4745 | (if (search-forward "\nfrom: " nil t) |
| 4437 | (funcall | 4746 | (funcall gnus-decode-encoded-word-function |
| 4438 | gnus-structured-field-decoder (nnheader-header-value)) | 4747 | (nnheader-header-value)) |
| 4439 | "(nobody)")) | 4748 | "(nobody)")) |
| 4440 | ;; Date. | 4749 | ;; Date. |
| 4441 | (progn | 4750 | (progn |
| @@ -4505,7 +4814,19 @@ The resulting hash table is returned, or nil if no Xrefs were found." | |||
| 4505 | (progn | 4814 | (progn |
| 4506 | (goto-char p) | 4815 | (goto-char p) |
| 4507 | (and (search-forward "\nxref: " nil t) | 4816 | (and (search-forward "\nxref: " nil t) |
| 4508 | (nnheader-header-value))))) | 4817 | (nnheader-header-value))) |
| 4818 | ;; Extra. | ||
| 4819 | (when gnus-extra-headers | ||
| 4820 | (let ((extra gnus-extra-headers) | ||
| 4821 | out) | ||
| 4822 | (while extra | ||
| 4823 | (goto-char p) | ||
| 4824 | (when (search-forward | ||
| 4825 | (concat "\n" (symbol-name (car extra)) ": ") nil t) | ||
| 4826 | (push (cons (car extra) (nnheader-header-value)) | ||
| 4827 | out)) | ||
| 4828 | (pop extra)) | ||
| 4829 | out)))) | ||
| 4509 | (when (equal id ref) | 4830 | (when (equal id ref) |
| 4510 | (setq ref nil)) | 4831 | (setq ref nil)) |
| 4511 | 4832 | ||
| @@ -4526,16 +4847,20 @@ The resulting hash table is returned, or nil if no Xrefs were found." | |||
| 4526 | (defun gnus-get-newsgroup-headers-xover (sequence &optional | 4847 | (defun gnus-get-newsgroup-headers-xover (sequence &optional |
| 4527 | force-new dependencies | 4848 | force-new dependencies |
| 4528 | group also-fetch-heads) | 4849 | group also-fetch-heads) |
| 4529 | "Parse the news overview data in the server buffer, and return a | 4850 | "Parse the news overview data in the server buffer. |
| 4530 | list of headers that match SEQUENCE (see `nntp-retrieve-headers')." | 4851 | Return a list of headers that match SEQUENCE (see |
| 4852 | `nntp-retrieve-headers')." | ||
| 4531 | ;; Get the Xref when the users reads the articles since most/some | 4853 | ;; Get the Xref when the users reads the articles since most/some |
| 4532 | ;; NNTP servers do not include Xrefs when using XOVER. | 4854 | ;; NNTP servers do not include Xrefs when using XOVER. |
| 4533 | (setq gnus-article-internal-prepare-hook '(gnus-article-get-xrefs)) | 4855 | (setq gnus-article-internal-prepare-hook '(gnus-article-get-xrefs)) |
| 4534 | (let ((cur nntp-server-buffer) | 4856 | (let ((mail-parse-charset gnus-newsgroup-charset) |
| 4857 | (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets) | ||
| 4858 | (cur nntp-server-buffer) | ||
| 4535 | (dependencies (or dependencies gnus-newsgroup-dependencies)) | 4859 | (dependencies (or dependencies gnus-newsgroup-dependencies)) |
| 4536 | number headers header) | 4860 | number headers header) |
| 4537 | (save-excursion | 4861 | (save-excursion |
| 4538 | (set-buffer nntp-server-buffer) | 4862 | (set-buffer nntp-server-buffer) |
| 4863 | (subst-char-in-region (point-min) (point-max) ?\r ? t) | ||
| 4539 | ;; Allow the user to mangle the headers before parsing them. | 4864 | ;; Allow the user to mangle the headers before parsing them. |
| 4540 | (gnus-run-hooks 'gnus-parse-headers-hook) | 4865 | (gnus-run-hooks 'gnus-parse-headers-hook) |
| 4541 | (goto-char (point-min)) | 4866 | (goto-char (point-min)) |
| @@ -4589,7 +4914,8 @@ This is meant to be called in `gnus-article-internal-prepare-hook'." | |||
| 4589 | (save-restriction | 4914 | (save-restriction |
| 4590 | (nnheader-narrow-to-headers) | 4915 | (nnheader-narrow-to-headers) |
| 4591 | (goto-char (point-min)) | 4916 | (goto-char (point-min)) |
| 4592 | (when (or (and (eq (downcase (following-char)) ?x) | 4917 | (when (or (and (not (eobp)) |
| 4918 | (eq (downcase (char-after)) ?x) | ||
| 4593 | (looking-at "Xref:")) | 4919 | (looking-at "Xref:")) |
| 4594 | (search-forward "\nXref:" nil t)) | 4920 | (search-forward "\nXref:" nil t)) |
| 4595 | (goto-char (1+ (match-end 0))) | 4921 | (goto-char (1+ (match-end 0))) |
| @@ -4604,14 +4930,14 @@ the subject line on." | |||
| 4604 | (let* ((line (and (numberp old-header) old-header)) | 4930 | (let* ((line (and (numberp old-header) old-header)) |
| 4605 | (old-header (and (vectorp old-header) old-header)) | 4931 | (old-header (and (vectorp old-header) old-header)) |
| 4606 | (header (cond ((and old-header use-old-header) | 4932 | (header (cond ((and old-header use-old-header) |
| 4607 | old-header) | 4933 | old-header) |
| 4608 | ((and (numberp id) | 4934 | ((and (numberp id) |
| 4609 | (gnus-number-to-header id)) | 4935 | (gnus-number-to-header id)) |
| 4610 | (gnus-number-to-header id)) | 4936 | (gnus-number-to-header id)) |
| 4611 | (t | 4937 | (t |
| 4612 | (gnus-read-header id)))) | 4938 | (gnus-read-header id)))) |
| 4613 | (number (and (numberp id) id)) | 4939 | (number (and (numberp id) id)) |
| 4614 | d) | 4940 | d) |
| 4615 | (when header | 4941 | (when header |
| 4616 | ;; Rebuild the thread that this article is part of and go to the | 4942 | ;; Rebuild the thread that this article is part of and go to the |
| 4617 | ;; article we have fetched. | 4943 | ;; article we have fetched. |
| @@ -4706,7 +5032,8 @@ executed with point over the summary line of the articles." | |||
| 4706 | `(let ((,articles (gnus-summary-work-articles ,arg))) | 5032 | `(let ((,articles (gnus-summary-work-articles ,arg))) |
| 4707 | (while ,articles | 5033 | (while ,articles |
| 4708 | (gnus-summary-goto-subject (car ,articles)) | 5034 | (gnus-summary-goto-subject (car ,articles)) |
| 4709 | ,@forms)))) | 5035 | ,@forms |
| 5036 | (pop ,articles))))) | ||
| 4710 | 5037 | ||
| 4711 | (put 'gnus-summary-iterate 'lisp-indent-function 1) | 5038 | (put 'gnus-summary-iterate 'lisp-indent-function 1) |
| 4712 | (put 'gnus-summary-iterate 'edebug-form-spec '(form body)) | 5039 | (put 'gnus-summary-iterate 'edebug-form-spec '(form body)) |
| @@ -4851,9 +5178,12 @@ If `gnus-auto-center-summary' is nil, or the article buffer isn't | |||
| 4851 | displayed, no centering will be performed." | 5178 | displayed, no centering will be performed." |
| 4852 | ;; Suggested by earle@mahendo.JPL.NASA.GOV (Greg Earle). | 5179 | ;; Suggested by earle@mahendo.JPL.NASA.GOV (Greg Earle). |
| 4853 | ;; Recenter only when requested. Suggested by popovich@park.cs.columbia.edu. | 5180 | ;; Recenter only when requested. Suggested by popovich@park.cs.columbia.edu. |
| 5181 | (interactive) | ||
| 4854 | (let* ((top (cond ((< (window-height) 4) 0) | 5182 | (let* ((top (cond ((< (window-height) 4) 0) |
| 4855 | ((< (window-height) 7) 1) | 5183 | ((< (window-height) 7) 1) |
| 4856 | (t 2))) | 5184 | (t (if (numberp gnus-auto-center-summary) |
| 5185 | gnus-auto-center-summary | ||
| 5186 | 2)))) | ||
| 4857 | (height (1- (window-height))) | 5187 | (height (1- (window-height))) |
| 4858 | (bottom (save-excursion (goto-char (point-max)) | 5188 | (bottom (save-excursion (goto-char (point-max)) |
| 4859 | (forward-line (- height)) | 5189 | (forward-line (- height)) |
| @@ -4868,7 +5198,8 @@ displayed, no centering will be performed." | |||
| 4868 | ;; whichever is the least. | 5198 | ;; whichever is the least. |
| 4869 | (set-window-start | 5199 | (set-window-start |
| 4870 | window (min bottom (save-excursion | 5200 | window (min bottom (save-excursion |
| 4871 | (forward-line (- top)) (point))))) | 5201 | (forward-line (- top)) (point))) |
| 5202 | t)) | ||
| 4872 | ;; Do horizontal recentering while we're at it. | 5203 | ;; Do horizontal recentering while we're at it. |
| 4873 | (when (and (get-buffer-window (current-buffer) t) | 5204 | (when (and (get-buffer-window (current-buffer) t) |
| 4874 | (not (eq gnus-auto-center-summary 'vertical))) | 5205 | (not (eq gnus-auto-center-summary 'vertical))) |
| @@ -4908,7 +5239,10 @@ displayed, no centering will be performed." | |||
| 4908 | ;; If the range of read articles is a single range, then the | 5239 | ;; If the range of read articles is a single range, then the |
| 4909 | ;; first unread article is the article after the last read | 5240 | ;; first unread article is the article after the last read |
| 4910 | ;; article. Sounds logical, doesn't it? | 5241 | ;; article. Sounds logical, doesn't it? |
| 4911 | (if (not (listp (cdr read))) | 5242 | (if (and (not (listp (cdr read))) |
| 5243 | (or (< (car read) (car active)) | ||
| 5244 | (progn (setq read (list read)) | ||
| 5245 | nil))) | ||
| 4912 | (setq first (max (car active) (1+ (cdr read)))) | 5246 | (setq first (max (car active) (1+ (cdr read)))) |
| 4913 | ;; `read' is a list of ranges. | 5247 | ;; `read' is a list of ranges. |
| 4914 | (when (/= (setq nlast (or (and (numberp (car read)) (car read)) | 5248 | (when (/= (setq nlast (or (and (numberp (car read)) (car read)) |
| @@ -4965,8 +5299,7 @@ displayed, no centering will be performed." | |||
| 4965 | (key-binding | 5299 | (key-binding |
| 4966 | (read-key-sequence | 5300 | (read-key-sequence |
| 4967 | (substitute-command-keys | 5301 | (substitute-command-keys |
| 4968 | "\\<gnus-summary-mode-map>\\[gnus-summary-universal-argument]" | 5302 | "\\<gnus-summary-mode-map>\\[gnus-summary-universal-argument]")))) |
| 4969 | )))) | ||
| 4970 | 'undefined) | 5303 | 'undefined) |
| 4971 | (gnus-error 1 "Undefined key") | 5304 | (gnus-error 1 "Undefined key") |
| 4972 | (save-excursion | 5305 | (save-excursion |
| @@ -5062,9 +5395,16 @@ If FORCE (the prefix), also save the .newsrc file(s)." | |||
| 5062 | 5395 | ||
| 5063 | (defun gnus-summary-exit (&optional temporary) | 5396 | (defun gnus-summary-exit (&optional temporary) |
| 5064 | "Exit reading current newsgroup, and then return to group selection mode. | 5397 | "Exit reading current newsgroup, and then return to group selection mode. |
| 5065 | gnus-exit-group-hook is called with no arguments if that value is non-nil." | 5398 | `gnus-exit-group-hook' is called with no arguments if that value is non-nil." |
| 5066 | (interactive) | 5399 | (interactive) |
| 5067 | (gnus-set-global-variables) | 5400 | (gnus-set-global-variables) |
| 5401 | (when (gnus-buffer-live-p gnus-article-buffer) | ||
| 5402 | (save-excursion | ||
| 5403 | (set-buffer gnus-article-buffer) | ||
| 5404 | (mm-destroy-parts gnus-article-mime-handles) | ||
| 5405 | ;; Set it to nil for safety reason. | ||
| 5406 | (setq gnus-article-mime-handle-alist nil) | ||
| 5407 | (setq gnus-article-mime-handles nil))) | ||
| 5068 | (gnus-kill-save-kill-buffer) | 5408 | (gnus-kill-save-kill-buffer) |
| 5069 | (gnus-async-halt-prefetch) | 5409 | (gnus-async-halt-prefetch) |
| 5070 | (let* ((group gnus-newsgroup-name) | 5410 | (let* ((group gnus-newsgroup-name) |
| @@ -5072,6 +5412,12 @@ gnus-exit-group-hook is called with no arguments if that value is non-nil." | |||
| 5072 | (mode major-mode) | 5412 | (mode major-mode) |
| 5073 | (group-point nil) | 5413 | (group-point nil) |
| 5074 | (buf (current-buffer))) | 5414 | (buf (current-buffer))) |
| 5415 | (unless quit-config | ||
| 5416 | ;; Do adaptive scoring, and possibly save score files. | ||
| 5417 | (when gnus-newsgroup-adaptive | ||
| 5418 | (gnus-score-adaptive)) | ||
| 5419 | (when gnus-use-scoring | ||
| 5420 | (gnus-score-save))) | ||
| 5075 | (gnus-run-hooks 'gnus-summary-prepare-exit-hook) | 5421 | (gnus-run-hooks 'gnus-summary-prepare-exit-hook) |
| 5076 | ;; If we have several article buffers, we kill them at exit. | 5422 | ;; If we have several article buffers, we kill them at exit. |
| 5077 | (unless gnus-single-article-buffer | 5423 | (unless gnus-single-article-buffer |
| @@ -5085,17 +5431,14 @@ gnus-exit-group-hook is called with no arguments if that value is non-nil." | |||
| 5085 | (gnus-dup-enter-articles)) | 5431 | (gnus-dup-enter-articles)) |
| 5086 | (when gnus-use-trees | 5432 | (when gnus-use-trees |
| 5087 | (gnus-tree-close group)) | 5433 | (gnus-tree-close group)) |
| 5434 | (when gnus-use-cache | ||
| 5435 | (gnus-cache-write-active)) | ||
| 5088 | ;; Remove entries for this group. | 5436 | ;; Remove entries for this group. |
| 5089 | (nnmail-purge-split-history (gnus-group-real-name group)) | 5437 | (nnmail-purge-split-history (gnus-group-real-name group)) |
| 5090 | ;; Make all changes in this group permanent. | 5438 | ;; Make all changes in this group permanent. |
| 5091 | (unless quit-config | 5439 | (unless quit-config |
| 5092 | (gnus-run-hooks 'gnus-exit-group-hook) | 5440 | (gnus-run-hooks 'gnus-exit-group-hook) |
| 5093 | (gnus-summary-update-info) | 5441 | (gnus-summary-update-info)) |
| 5094 | ;; Do adaptive scoring, and possibly save score files. | ||
| 5095 | (when gnus-newsgroup-adaptive | ||
| 5096 | (gnus-score-adaptive)) | ||
| 5097 | (when gnus-use-scoring | ||
| 5098 | (gnus-score-save))) | ||
| 5099 | (gnus-close-group group) | 5442 | (gnus-close-group group) |
| 5100 | ;; Make sure where we were, and go to next newsgroup. | 5443 | ;; Make sure where we were, and go to next newsgroup. |
| 5101 | (set-buffer gnus-group-buffer) | 5444 | (set-buffer gnus-group-buffer) |
| @@ -5153,7 +5496,16 @@ gnus-exit-group-hook is called with no arguments if that value is non-nil." | |||
| 5153 | gnus-expert-user | 5496 | gnus-expert-user |
| 5154 | (gnus-y-or-n-p "Discard changes to this group and exit? ")) | 5497 | (gnus-y-or-n-p "Discard changes to this group and exit? ")) |
| 5155 | (gnus-async-halt-prefetch) | 5498 | (gnus-async-halt-prefetch) |
| 5156 | (gnus-run-hooks 'gnus-summary-prepare-exit-hook) | 5499 | (mapcar 'funcall |
| 5500 | (delq 'gnus-summary-expire-articles | ||
| 5501 | (copy-sequence gnus-summary-prepare-exit-hook))) | ||
| 5502 | (when (gnus-buffer-live-p gnus-article-buffer) | ||
| 5503 | (save-excursion | ||
| 5504 | (set-buffer gnus-article-buffer) | ||
| 5505 | (mm-destroy-parts gnus-article-mime-handles) | ||
| 5506 | ;; Set it to nil for safety reason. | ||
| 5507 | (setq gnus-article-mime-handle-alist nil) | ||
| 5508 | (setq gnus-article-mime-handles nil))) | ||
| 5157 | ;; If we have several article buffers, we kill them at exit. | 5509 | ;; If we have several article buffers, we kill them at exit. |
| 5158 | (unless gnus-single-article-buffer | 5510 | (unless gnus-single-article-buffer |
| 5159 | (gnus-kill-buffer gnus-article-buffer) | 5511 | (gnus-kill-buffer gnus-article-buffer) |
| @@ -5261,7 +5613,8 @@ The state which existed when entering the ephemeral is reset." | |||
| 5261 | (rename-buffer | 5613 | (rename-buffer |
| 5262 | (concat (substring name 0 (match-beginning 0)) "Dead " | 5614 | (concat (substring name 0 (match-beginning 0)) "Dead " |
| 5263 | (substring name (match-beginning 0))) | 5615 | (substring name (match-beginning 0))) |
| 5264 | t)))) | 5616 | t) |
| 5617 | (bury-buffer)))) | ||
| 5265 | 5618 | ||
| 5266 | (defun gnus-kill-or-deaden-summary (buffer) | 5619 | (defun gnus-kill-or-deaden-summary (buffer) |
| 5267 | "Kill or deaden the summary BUFFER." | 5620 | "Kill or deaden the summary BUFFER." |
| @@ -5322,8 +5675,7 @@ in." | |||
| 5322 | (defun gnus-summary-describe-briefly () | 5675 | (defun gnus-summary-describe-briefly () |
| 5323 | "Describe summary mode commands briefly." | 5676 | "Describe summary mode commands briefly." |
| 5324 | (interactive) | 5677 | (interactive) |
| 5325 | (gnus-message 6 | 5678 | (gnus-message 6 (substitute-command-keys "\\<gnus-summary-mode-map>\\[gnus-summary-next-page]:Select \\[gnus-summary-next-unread-article]:Forward \\[gnus-summary-prev-unread-article]:Backward \\[gnus-summary-exit]:Exit \\[gnus-info-find-node]:Run Info \\[gnus-summary-describe-briefly]:This help"))) |
| 5326 | (substitute-command-keys "\\<gnus-summary-mode-map>\\[gnus-summary-next-page]:Select \\[gnus-summary-next-unread-article]:Forward \\[gnus-summary-prev-unread-article]:Backward \\[gnus-summary-exit]:Exit \\[gnus-info-find-node]:Run Info \\[gnus-summary-describe-briefly]:This help"))) | ||
| 5327 | 5679 | ||
| 5328 | ;; Walking around group mode buffer from summary mode. | 5680 | ;; Walking around group mode buffer from summary mode. |
| 5329 | 5681 | ||
| @@ -5429,8 +5781,8 @@ returned." | |||
| 5429 | (if backward | 5781 | (if backward |
| 5430 | (gnus-summary-find-prev unread) | 5782 | (gnus-summary-find-prev unread) |
| 5431 | (gnus-summary-find-next unread))) | 5783 | (gnus-summary-find-next unread))) |
| 5432 | (gnus-summary-show-thread) | 5784 | (unless (zerop (setq n (1- n))) |
| 5433 | (setq n (1- n))) | 5785 | (gnus-summary-show-thread))) |
| 5434 | (when (/= 0 n) | 5786 | (when (/= 0 n) |
| 5435 | (gnus-message 7 "No more%s articles" | 5787 | (gnus-message 7 "No more%s articles" |
| 5436 | (if unread " unread" ""))) | 5788 | (if unread " unread" ""))) |
| @@ -5521,35 +5873,41 @@ be displayed." | |||
| 5521 | (set-buffer gnus-summary-buffer)) | 5873 | (set-buffer gnus-summary-buffer)) |
| 5522 | (let ((article (or article (gnus-summary-article-number))) | 5874 | (let ((article (or article (gnus-summary-article-number))) |
| 5523 | (all-headers (not (not all-headers))) ;Must be T or NIL. | 5875 | (all-headers (not (not all-headers))) ;Must be T or NIL. |
| 5524 | gnus-summary-display-article-function | 5876 | gnus-summary-display-article-function) |
| 5525 | did) | ||
| 5526 | (and (not pseudo) | 5877 | (and (not pseudo) |
| 5527 | (gnus-summary-article-pseudo-p article) | 5878 | (gnus-summary-article-pseudo-p article) |
| 5528 | (error "This is a pseudo-article")) | 5879 | (error "This is a pseudo-article")) |
| 5529 | (prog1 | 5880 | (save-excursion |
| 5530 | (save-excursion | 5881 | (set-buffer gnus-summary-buffer) |
| 5531 | (set-buffer gnus-summary-buffer) | 5882 | (if (or (and gnus-single-article-buffer |
| 5532 | (if (or (and gnus-single-article-buffer | 5883 | (or (null gnus-current-article) |
| 5533 | (or (null gnus-current-article) | 5884 | (null gnus-article-current) |
| 5534 | (null gnus-article-current) | 5885 | (null (get-buffer gnus-article-buffer)) |
| 5535 | (null (get-buffer gnus-article-buffer)) | 5886 | (not (eq article (cdr gnus-article-current))) |
| 5536 | (not (eq article (cdr gnus-article-current))) | 5887 | (not (equal (car gnus-article-current) |
| 5537 | (not (equal (car gnus-article-current) | 5888 | gnus-newsgroup-name)))) |
| 5538 | gnus-newsgroup-name)))) | 5889 | (and (not gnus-single-article-buffer) |
| 5539 | (and (not gnus-single-article-buffer) | 5890 | (or (null gnus-current-article) |
| 5540 | (or (null gnus-current-article) | 5891 | (not (eq gnus-current-article article)))) |
| 5541 | (not (eq gnus-current-article article)))) | 5892 | force) |
| 5542 | force) | 5893 | ;; The requested article is different from the current article. |
| 5543 | ;; The requested article is different from the current article. | 5894 | (progn |
| 5544 | (prog1 | 5895 | (when (gnus-buffer-live-p gnus-article-buffer) |
| 5545 | (gnus-summary-display-article article all-headers) | 5896 | (with-current-buffer gnus-article-buffer |
| 5546 | (setq did article)) | 5897 | (mm-enable-multibyte))) |
| 5898 | (gnus-summary-display-article article all-headers) | ||
| 5899 | (when (gnus-buffer-live-p gnus-article-buffer) | ||
| 5900 | (with-current-buffer gnus-article-buffer | ||
| 5901 | (if (not gnus-article-decoded-p) ;; a local variable | ||
| 5902 | (mm-disable-multibyte)))) | ||
| 5547 | (when (or all-headers gnus-show-all-headers) | 5903 | (when (or all-headers gnus-show-all-headers) |
| 5548 | (gnus-article-show-all-headers)) | 5904 | (gnus-article-show-all-headers)) |
| 5549 | 'old)) | 5905 | (gnus-article-set-window-start |
| 5550 | (when did | 5906 | (cdr (assq article gnus-newsgroup-bookmarks))) |
| 5551 | (gnus-article-set-window-start | 5907 | article) |
| 5552 | (cdr (assq article gnus-newsgroup-bookmarks))))))) | 5908 | (when (or all-headers gnus-show-all-headers) |
| 5909 | (gnus-article-show-all-headers)) | ||
| 5910 | 'old)))) | ||
| 5553 | 5911 | ||
| 5554 | (defun gnus-summary-set-current-mark (&optional current-mark) | 5912 | (defun gnus-summary-set-current-mark (&optional current-mark) |
| 5555 | "Obsolete function." | 5913 | "Obsolete function." |
| @@ -5821,15 +6179,25 @@ Return nil if there are no unread articles." | |||
| 5821 | (gnus-summary-display-article (gnus-summary-article-number))) | 6179 | (gnus-summary-display-article (gnus-summary-article-number))) |
| 5822 | (gnus-summary-position-point))) | 6180 | (gnus-summary-position-point))) |
| 5823 | 6181 | ||
| 6182 | (defun gnus-summary-first-unread-subject () | ||
| 6183 | "Place the point on the subject line of the first unread article. | ||
| 6184 | Return nil if there are no unread articles." | ||
| 6185 | (interactive) | ||
| 6186 | (prog1 | ||
| 6187 | (when (gnus-summary-first-subject t) | ||
| 6188 | (gnus-summary-show-thread) | ||
| 6189 | (gnus-summary-first-subject t)) | ||
| 6190 | (gnus-summary-position-point))) | ||
| 6191 | |||
| 5824 | (defun gnus-summary-first-article () | 6192 | (defun gnus-summary-first-article () |
| 5825 | "Select the first article. | 6193 | "Select the first article. |
| 5826 | Return nil if there are no articles." | 6194 | Return nil if there are no articles." |
| 5827 | (interactive) | 6195 | (interactive) |
| 5828 | (prog1 | 6196 | (prog1 |
| 5829 | (when (gnus-summary-first-subject) | 6197 | (when (gnus-summary-first-subject) |
| 5830 | (gnus-summary-show-thread) | 6198 | (gnus-summary-show-thread) |
| 5831 | (gnus-summary-first-subject) | 6199 | (gnus-summary-first-subject) |
| 5832 | (gnus-summary-display-article (gnus-summary-article-number))) | 6200 | (gnus-summary-display-article (gnus-summary-article-number))) |
| 5833 | (gnus-summary-position-point))) | 6201 | (gnus-summary-position-point))) |
| 5834 | 6202 | ||
| 5835 | (defun gnus-summary-best-unread-article () | 6203 | (defun gnus-summary-best-unread-article () |
| @@ -5951,16 +6319,32 @@ If given a prefix, remove all limits." | |||
| 5951 | "Limit the summary buffer to articles that are older than (or equal) AGE days. | 6319 | "Limit the summary buffer to articles that are older than (or equal) AGE days. |
| 5952 | If YOUNGER-P (the prefix) is non-nil, limit the summary buffer to | 6320 | If YOUNGER-P (the prefix) is non-nil, limit the summary buffer to |
| 5953 | articles that are younger than AGE days." | 6321 | articles that are younger than AGE days." |
| 5954 | (interactive "nTime in days: \nP") | 6322 | (interactive |
| 6323 | (let ((younger current-prefix-arg) | ||
| 6324 | (days-got nil) | ||
| 6325 | days) | ||
| 6326 | (while (not days-got) | ||
| 6327 | (setq days (if younger | ||
| 6328 | (read-string "Limit to articles within (in days): ") | ||
| 6329 | (read-string "Limit to articles old than (in days): "))) | ||
| 6330 | (when (> (length days) 0) | ||
| 6331 | (setq days (read days))) | ||
| 6332 | (if (numberp days) | ||
| 6333 | (setq days-got t) | ||
| 6334 | (message "Please enter a number.") | ||
| 6335 | (sleep-for 1))) | ||
| 6336 | (list days younger))) | ||
| 5955 | (prog1 | 6337 | (prog1 |
| 5956 | (let ((data gnus-newsgroup-data) | 6338 | (let ((data gnus-newsgroup-data) |
| 5957 | (cutoff (nnmail-days-to-time age)) | 6339 | (cutoff (days-to-time age)) |
| 5958 | articles d date is-younger) | 6340 | articles d date is-younger) |
| 5959 | (while (setq d (pop data)) | 6341 | (while (setq d (pop data)) |
| 5960 | (when (and (vectorp (gnus-data-header d)) | 6342 | (when (and (vectorp (gnus-data-header d)) |
| 5961 | (setq date (mail-header-date (gnus-data-header d)))) | 6343 | (setq date (mail-header-date (gnus-data-header d)))) |
| 5962 | (setq is-younger (nnmail-time-less | 6344 | (setq is-younger (time-less-p |
| 5963 | (nnmail-time-since (nnmail-date-to-time date)) | 6345 | (time-since (condition-case () |
| 6346 | (date-to-time date) | ||
| 6347 | (error '(0 0)))) | ||
| 5964 | cutoff)) | 6348 | cutoff)) |
| 5965 | (when (if younger-p | 6349 | (when (if younger-p |
| 5966 | is-younger | 6350 | is-younger |
| @@ -5969,6 +6353,30 @@ articles that are younger than AGE days." | |||
| 5969 | (gnus-summary-limit (nreverse articles))) | 6353 | (gnus-summary-limit (nreverse articles))) |
| 5970 | (gnus-summary-position-point))) | 6354 | (gnus-summary-position-point))) |
| 5971 | 6355 | ||
| 6356 | (defun gnus-summary-limit-to-extra (header regexp) | ||
| 6357 | "Limit the summary buffer to articles that match an 'extra' header." | ||
| 6358 | (interactive | ||
| 6359 | (let ((header | ||
| 6360 | (intern | ||
| 6361 | (gnus-completing-read | ||
| 6362 | (symbol-name (car gnus-extra-headers)) | ||
| 6363 | "Limit extra header:" | ||
| 6364 | (mapcar (lambda (x) | ||
| 6365 | (cons (symbol-name x) x)) | ||
| 6366 | gnus-extra-headers) | ||
| 6367 | nil | ||
| 6368 | t)))) | ||
| 6369 | (list header | ||
| 6370 | (read-string (format "Limit to header %s (regexp): " header))))) | ||
| 6371 | (when (not (equal "" regexp)) | ||
| 6372 | (prog1 | ||
| 6373 | (let ((articles (gnus-summary-find-matching | ||
| 6374 | (cons 'extra header) regexp 'all))) | ||
| 6375 | (unless articles | ||
| 6376 | (error "Found no matches for \"%s\"" regexp)) | ||
| 6377 | (gnus-summary-limit articles)) | ||
| 6378 | (gnus-summary-position-point)))) | ||
| 6379 | |||
| 5972 | (defalias 'gnus-summary-delete-marked-as-read 'gnus-summary-limit-to-unread) | 6380 | (defalias 'gnus-summary-delete-marked-as-read 'gnus-summary-limit-to-unread) |
| 5973 | (make-obsolete | 6381 | (make-obsolete |
| 5974 | 'gnus-summary-delete-marked-as-read 'gnus-summary-limit-to-unread) | 6382 | 'gnus-summary-delete-marked-as-read 'gnus-summary-limit-to-unread) |
| @@ -6166,6 +6574,7 @@ If ALL, mark even excluded ticked and dormants as read." | |||
| 6166 | "Go forwards in the thread until we find an article that we want to display." | 6574 | "Go forwards in the thread until we find an article that we want to display." |
| 6167 | (when (or (eq gnus-fetch-old-headers 'some) | 6575 | (when (or (eq gnus-fetch-old-headers 'some) |
| 6168 | (eq gnus-fetch-old-headers 'invisible) | 6576 | (eq gnus-fetch-old-headers 'invisible) |
| 6577 | (numberp gnus-fetch-old-headers) | ||
| 6169 | (eq gnus-build-sparse-threads 'some) | 6578 | (eq gnus-build-sparse-threads 'some) |
| 6170 | (eq gnus-build-sparse-threads 'more)) | 6579 | (eq gnus-build-sparse-threads 'more)) |
| 6171 | ;; Deal with old-fetched headers and sparse threads. | 6580 | ;; Deal with old-fetched headers and sparse threads. |
| @@ -6195,6 +6604,7 @@ If ALL, mark even excluded ticked and dormants as read." | |||
| 6195 | "Cut off all uninteresting articles from the beginning of threads." | 6604 | "Cut off all uninteresting articles from the beginning of threads." |
| 6196 | (when (or (eq gnus-fetch-old-headers 'some) | 6605 | (when (or (eq gnus-fetch-old-headers 'some) |
| 6197 | (eq gnus-fetch-old-headers 'invisible) | 6606 | (eq gnus-fetch-old-headers 'invisible) |
| 6607 | (numberp gnus-fetch-old-headers) | ||
| 6198 | (eq gnus-build-sparse-threads 'some) | 6608 | (eq gnus-build-sparse-threads 'some) |
| 6199 | (eq gnus-build-sparse-threads 'more)) | 6609 | (eq gnus-build-sparse-threads 'more)) |
| 6200 | (let ((th threads)) | 6610 | (let ((th threads)) |
| @@ -6212,6 +6622,7 @@ fetch-old-headers verbiage, and so on." | |||
| 6212 | (if (or gnus-inhibit-limiting | 6622 | (if (or gnus-inhibit-limiting |
| 6213 | (and (null gnus-newsgroup-dormant) | 6623 | (and (null gnus-newsgroup-dormant) |
| 6214 | (not (eq gnus-fetch-old-headers 'some)) | 6624 | (not (eq gnus-fetch-old-headers 'some)) |
| 6625 | (not (numberp gnus-fetch-old-headers)) | ||
| 6215 | (not (eq gnus-fetch-old-headers 'invisible)) | 6626 | (not (eq gnus-fetch-old-headers 'invisible)) |
| 6216 | (null gnus-summary-expunge-below) | 6627 | (null gnus-summary-expunge-below) |
| 6217 | (not (eq gnus-build-sparse-threads 'some)) | 6628 | (not (eq gnus-build-sparse-threads 'some)) |
| @@ -6265,7 +6676,8 @@ fetch-old-headers verbiage, and so on." | |||
| 6265 | (zerop children)) | 6676 | (zerop children)) |
| 6266 | ;; If this is "fetch-old-headered" and there is no | 6677 | ;; If this is "fetch-old-headered" and there is no |
| 6267 | ;; visible children, then we don't want this article. | 6678 | ;; visible children, then we don't want this article. |
| 6268 | (and (eq gnus-fetch-old-headers 'some) | 6679 | (and (or (eq gnus-fetch-old-headers 'some) |
| 6680 | (numberp gnus-fetch-old-headers)) | ||
| 6269 | (gnus-summary-article-ancient-p number) | 6681 | (gnus-summary-article-ancient-p number) |
| 6270 | (zerop children)) | 6682 | (zerop children)) |
| 6271 | ;; If this is "fetch-old-headered" and `invisible', then | 6683 | ;; If this is "fetch-old-headered" and `invisible', then |
| @@ -6416,11 +6828,9 @@ of what's specified by the `gnus-refer-thread-limit' variable." | |||
| 6416 | (gnus-message 5 "Fetching headers for %s...done" gnus-newsgroup-name)) | 6828 | (gnus-message 5 "Fetching headers for %s...done" gnus-newsgroup-name)) |
| 6417 | (gnus-summary-limit-include-thread id))) | 6829 | (gnus-summary-limit-include-thread id))) |
| 6418 | 6830 | ||
| 6419 | (defun gnus-summary-refer-article (message-id &optional arg) | 6831 | (defun gnus-summary-refer-article (message-id) |
| 6420 | "Fetch an article specified by MESSAGE-ID. | 6832 | "Fetch an article specified by MESSAGE-ID." |
| 6421 | If ARG (the prefix), fetch the article using `gnus-refer-article-method' | 6833 | (interactive "sMessage-ID: ") |
| 6422 | or `gnus-select-method', no matter what backend the article comes from." | ||
| 6423 | (interactive "sMessage-ID: \nP") | ||
| 6424 | (when (and (stringp message-id) | 6834 | (when (and (stringp message-id) |
| 6425 | (not (zerop (length message-id)))) | 6835 | (not (zerop (length message-id)))) |
| 6426 | ;; Construct the correct Message-ID if necessary. | 6836 | ;; Construct the correct Message-ID if necessary. |
| @@ -6434,7 +6844,8 @@ or `gnus-select-method', no matter what backend the article comes from." | |||
| 6434 | (gnus-summary-article-sparse-p | 6844 | (gnus-summary-article-sparse-p |
| 6435 | (mail-header-number header)) | 6845 | (mail-header-number header)) |
| 6436 | (memq (mail-header-number header) | 6846 | (memq (mail-header-number header) |
| 6437 | gnus-newsgroup-limit)))) | 6847 | gnus-newsgroup-limit))) |
| 6848 | number) | ||
| 6438 | (cond | 6849 | (cond |
| 6439 | ;; If the article is present in the buffer we just go to it. | 6850 | ;; If the article is present in the buffer we just go to it. |
| 6440 | ((and header | 6851 | ((and header |
| @@ -6447,28 +6858,48 @@ or `gnus-select-method', no matter what backend the article comes from." | |||
| 6447 | (when sparse | 6858 | (when sparse |
| 6448 | (gnus-summary-update-article (mail-header-number header))))) | 6859 | (gnus-summary-update-article (mail-header-number header))))) |
| 6449 | (t | 6860 | (t |
| 6450 | ;; We fetch the article | 6861 | ;; We fetch the article. |
| 6451 | (let ((gnus-override-method | 6862 | (catch 'found |
| 6452 | (cond ((gnus-news-group-p gnus-newsgroup-name) | 6863 | (dolist (gnus-override-method (gnus-refer-article-methods)) |
| 6453 | gnus-refer-article-method) | 6864 | (gnus-check-server gnus-override-method) |
| 6454 | (arg | 6865 | ;; Fetch the header, and display the article. |
| 6455 | (or gnus-refer-article-method gnus-select-method)) | 6866 | (when (setq number (gnus-summary-insert-subject message-id)) |
| 6456 | (t nil))) | ||
| 6457 | number) | ||
| 6458 | ;; Start the special refer-article method, if necessary. | ||
| 6459 | (when (and gnus-refer-article-method | ||
| 6460 | (gnus-news-group-p gnus-newsgroup-name)) | ||
| 6461 | (gnus-check-server gnus-refer-article-method)) | ||
| 6462 | ;; Fetch the header, and display the article. | ||
| 6463 | (if (setq number (gnus-summary-insert-subject message-id)) | ||
| 6464 | (gnus-summary-select-article nil nil nil number) | 6867 | (gnus-summary-select-article nil nil nil number) |
| 6465 | (gnus-message 3 "Couldn't fetch article %s" message-id)))))))) | 6868 | (throw 'found t))) |
| 6869 | (gnus-message 3 "Couldn't fetch article %s" message-id))))))) | ||
| 6870 | |||
| 6871 | (defun gnus-refer-article-methods () | ||
| 6872 | "Return a list of referrable methods." | ||
| 6873 | (cond | ||
| 6874 | ;; No method, so we default to current and native. | ||
| 6875 | ((null gnus-refer-article-method) | ||
| 6876 | (list gnus-current-select-method gnus-select-method)) | ||
| 6877 | ;; Current. | ||
| 6878 | ((eq 'current gnus-refer-article-method) | ||
| 6879 | (list gnus-current-select-method)) | ||
| 6880 | ;; List of select methods. | ||
| 6881 | ((not (stringp (cadr gnus-refer-article-method))) | ||
| 6882 | (let (out) | ||
| 6883 | (dolist (method gnus-refer-article-method) | ||
| 6884 | (push (if (eq 'current method) | ||
| 6885 | gnus-current-select-method | ||
| 6886 | method) | ||
| 6887 | out)) | ||
| 6888 | (nreverse out))) | ||
| 6889 | ;; One single select method. | ||
| 6890 | (t | ||
| 6891 | (list gnus-refer-article-method)))) | ||
| 6466 | 6892 | ||
| 6467 | (defun gnus-summary-edit-parameters () | 6893 | (defun gnus-summary-edit-parameters () |
| 6468 | "Edit the group parameters of the current group." | 6894 | "Edit the group parameters of the current group." |
| 6469 | (interactive) | 6895 | (interactive) |
| 6470 | (gnus-group-edit-group gnus-newsgroup-name 'params)) | 6896 | (gnus-group-edit-group gnus-newsgroup-name 'params)) |
| 6471 | 6897 | ||
| 6898 | (defun gnus-summary-customize-parameters () | ||
| 6899 | "Customize the group parameters of the current group." | ||
| 6900 | (interactive) | ||
| 6901 | (gnus-group-customize gnus-newsgroup-name)) | ||
| 6902 | |||
| 6472 | (defun gnus-summary-enter-digest-group (&optional force) | 6903 | (defun gnus-summary-enter-digest-group (&optional force) |
| 6473 | "Enter an nndoc group based on the current article. | 6904 | "Enter an nndoc group based on the current article. |
| 6474 | If FORCE, force a digest interpretation. If not, try | 6905 | If FORCE, force a digest interpretation. If not, try |
| @@ -6490,8 +6921,14 @@ to guess what the document format is." | |||
| 6490 | (list (cons 'save-article-group ogroup)))) | 6921 | (list (cons 'save-article-group ogroup)))) |
| 6491 | (case-fold-search t) | 6922 | (case-fold-search t) |
| 6492 | (buf (current-buffer)) | 6923 | (buf (current-buffer)) |
| 6493 | dig) | 6924 | dig to-address) |
| 6494 | (save-excursion | 6925 | (save-excursion |
| 6926 | (set-buffer gnus-original-article-buffer) | ||
| 6927 | ;; Have the digest group inherit the main mail address of | ||
| 6928 | ;; the parent article. | ||
| 6929 | (when (setq to-address (or (message-fetch-field "reply-to") | ||
| 6930 | (message-fetch-field "from"))) | ||
| 6931 | (setq params (append (list (cons 'to-address to-address))))) | ||
| 6495 | (setq dig (nnheader-set-temp-buffer " *gnus digest buffer*")) | 6932 | (setq dig (nnheader-set-temp-buffer " *gnus digest buffer*")) |
| 6496 | (insert-buffer-substring gnus-original-article-buffer) | 6933 | (insert-buffer-substring gnus-original-article-buffer) |
| 6497 | ;; Remove lines that may lead nndoc to misinterpret the | 6934 | ;; Remove lines that may lead nndoc to misinterpret the |
| @@ -6500,14 +6937,17 @@ to guess what the document format is." | |||
| 6500 | (goto-char (point-min)) | 6937 | (goto-char (point-min)) |
| 6501 | (or (search-forward "\n\n" nil t) (point))) | 6938 | (or (search-forward "\n\n" nil t) (point))) |
| 6502 | (goto-char (point-min)) | 6939 | (goto-char (point-min)) |
| 6503 | (delete-matching-lines "^\\(Path\\):\\|^From ") | 6940 | (delete-matching-lines "^Path:\\|^From ") |
| 6504 | (widen)) | 6941 | (widen)) |
| 6505 | (unwind-protect | 6942 | (unwind-protect |
| 6506 | (if (gnus-group-read-ephemeral-group | 6943 | (if (let ((gnus-newsgroup-ephemeral-charset gnus-newsgroup-charset) |
| 6507 | name `(nndoc ,name (nndoc-address ,(get-buffer dig)) | 6944 | (gnus-newsgroup-ephemeral-ignored-charsets |
| 6508 | (nndoc-article-type | 6945 | gnus-newsgroup-ignored-charsets)) |
| 6509 | ,(if force 'digest 'guess))) t) | 6946 | (gnus-group-read-ephemeral-group |
| 6510 | ;; Make all postings to this group go to the parent group. | 6947 | name `(nndoc ,name (nndoc-address ,(get-buffer dig)) |
| 6948 | (nndoc-article-type | ||
| 6949 | ,(if force 'mbox 'guess))) t)) | ||
| 6950 | ;; Make all postings to this group go to the parent group. | ||
| 6511 | (nconc (gnus-info-params (gnus-get-info name)) | 6951 | (nconc (gnus-info-params (gnus-get-info name)) |
| 6512 | params) | 6952 | params) |
| 6513 | ;; Couldn't select this doc group. | 6953 | ;; Couldn't select this doc group. |
| @@ -6533,7 +6973,7 @@ Obeys the standard process/prefix convention." | |||
| 6533 | (gnus-summary-remove-process-mark article) | 6973 | (gnus-summary-remove-process-mark article) |
| 6534 | (when (gnus-summary-display-article article) | 6974 | (when (gnus-summary-display-article article) |
| 6535 | (save-excursion | 6975 | (save-excursion |
| 6536 | (nnheader-temp-write nil | 6976 | (with-temp-buffer |
| 6537 | (insert-buffer-substring gnus-original-article-buffer) | 6977 | (insert-buffer-substring gnus-original-article-buffer) |
| 6538 | ;; Remove some headers that may lead nndoc to make | 6978 | ;; Remove some headers that may lead nndoc to make |
| 6539 | ;; the wrong guess. | 6979 | ;; the wrong guess. |
| @@ -6613,18 +7053,21 @@ Optional argument BACKWARD means do search for backward. | |||
| 6613 | ;; We have to require this here to make sure that the following | 7053 | ;; We have to require this here to make sure that the following |
| 6614 | ;; dynamic binding isn't shadowed by autoloading. | 7054 | ;; dynamic binding isn't shadowed by autoloading. |
| 6615 | (require 'gnus-async) | 7055 | (require 'gnus-async) |
| 7056 | (require 'gnus-art) | ||
| 6616 | (let ((gnus-select-article-hook nil) ;Disable hook. | 7057 | (let ((gnus-select-article-hook nil) ;Disable hook. |
| 6617 | (gnus-article-display-hook nil) | 7058 | (gnus-article-prepare-hook nil) |
| 6618 | (gnus-mark-article-hook nil) ;Inhibit marking as read. | 7059 | (gnus-mark-article-hook nil) ;Inhibit marking as read. |
| 6619 | (gnus-use-article-prefetch nil) | 7060 | (gnus-use-article-prefetch nil) |
| 6620 | (gnus-xmas-force-redisplay nil) ;Inhibit XEmacs redisplay. | 7061 | (gnus-xmas-force-redisplay nil) ;Inhibit XEmacs redisplay. |
| 6621 | (gnus-use-trees nil) ;Inhibit updating tree buffer. | 7062 | (gnus-use-trees nil) ;Inhibit updating tree buffer. |
| 6622 | (sum (current-buffer)) | 7063 | (sum (current-buffer)) |
| 7064 | (gnus-display-mime-function nil) | ||
| 6623 | (found nil) | 7065 | (found nil) |
| 6624 | point) | 7066 | point) |
| 6625 | (gnus-save-hidden-threads | 7067 | (gnus-save-hidden-threads |
| 6626 | (gnus-summary-select-article) | 7068 | (gnus-summary-select-article) |
| 6627 | (set-buffer gnus-article-buffer) | 7069 | (set-buffer gnus-article-buffer) |
| 7070 | (goto-char (window-point (get-buffer-window (current-buffer)))) | ||
| 6628 | (when backward | 7071 | (when backward |
| 6629 | (forward-line -1)) | 7072 | (forward-line -1)) |
| 6630 | (while (not found) | 7073 | (while (not found) |
| @@ -6640,6 +7083,9 @@ Optional argument BACKWARD means do search for backward. | |||
| 6640 | (get-buffer-window (current-buffer)) | 7083 | (get-buffer-window (current-buffer)) |
| 6641 | (point)) | 7084 | (point)) |
| 6642 | (forward-line 1) | 7085 | (forward-line 1) |
| 7086 | (set-window-point | ||
| 7087 | (get-buffer-window (current-buffer)) | ||
| 7088 | (point)) | ||
| 6643 | (set-buffer sum) | 7089 | (set-buffer sum) |
| 6644 | (setq point (point))) | 7090 | (setq point (point))) |
| 6645 | ;; We didn't find it, so we go to the next article. | 7091 | ;; We didn't find it, so we go to the next article. |
| @@ -6678,11 +7124,18 @@ in the comparisons." | |||
| 6678 | (let ((data (if (eq backward 'all) gnus-newsgroup-data | 7124 | (let ((data (if (eq backward 'all) gnus-newsgroup-data |
| 6679 | (gnus-data-find-list | 7125 | (gnus-data-find-list |
| 6680 | (gnus-summary-article-number) (gnus-data-list backward)))) | 7126 | (gnus-summary-article-number) (gnus-data-list backward)))) |
| 6681 | (func `(lambda (h) (,(intern (concat "mail-header-" header)) h))) | ||
| 6682 | (case-fold-search (not not-case-fold)) | 7127 | (case-fold-search (not not-case-fold)) |
| 6683 | articles d) | 7128 | articles d func) |
| 6684 | (unless (fboundp (intern (concat "mail-header-" header))) | 7129 | (if (consp header) |
| 6685 | (error "%s is not a valid header" header)) | 7130 | (if (eq (car header) 'extra) |
| 7131 | (setq func | ||
| 7132 | `(lambda (h) | ||
| 7133 | (or (cdr (assq ',(cdr header) (mail-header-extra h))) | ||
| 7134 | ""))) | ||
| 7135 | (error "%s is an invalid header" header)) | ||
| 7136 | (unless (fboundp (intern (concat "mail-header-" header))) | ||
| 7137 | (error "%s is not a valid header" header)) | ||
| 7138 | (setq func `(lambda (h) (,(intern (concat "mail-header-" header)) h)))) | ||
| 6686 | (while data | 7139 | (while data |
| 6687 | (setq d (car data)) | 7140 | (setq d (car data)) |
| 6688 | (and (or (not unread) ; We want all articles... | 7141 | (and (or (not unread) ; We want all articles... |
| @@ -6751,7 +7204,7 @@ article. If BACKWARD (the prefix) is non-nil, search backward instead." | |||
| 6751 | If N is negative, print the N previous articles. If N is nil and articles | 7204 | If N is negative, print the N previous articles. If N is nil and articles |
| 6752 | have been marked with the process mark, print these instead. | 7205 | have been marked with the process mark, print these instead. |
| 6753 | 7206 | ||
| 6754 | If the optional second argument FILENAME is nil, send the image to the | 7207 | If the optional first argument FILENAME is nil, send the image to the |
| 6755 | printer. If FILENAME is a string, save the PostScript image in a file with | 7208 | printer. If FILENAME is a string, save the PostScript image in a file with |
| 6756 | that name. If FILENAME is a number, prompt the user for the name of the file | 7209 | that name. If FILENAME is a number, prompt the user for the name of the file |
| 6757 | to save in." | 7210 | to save in." |
| @@ -6784,20 +7237,42 @@ to save in." | |||
| 6784 | 7237 | ||
| 6785 | (defun gnus-summary-show-article (&optional arg) | 7238 | (defun gnus-summary-show-article (&optional arg) |
| 6786 | "Force re-fetching of the current article. | 7239 | "Force re-fetching of the current article. |
| 6787 | If ARG (the prefix) is non-nil, show the raw article without any | 7240 | If ARG (the prefix) is a number, show the article with the charset |
| 6788 | article massaging functions being run." | 7241 | defined in `gnus-summary-show-article-charset-alist', or the charset |
| 7242 | inputed. | ||
| 7243 | If ARG (the prefix) is non-nil and not a number, show the raw article | ||
| 7244 | without any article massaging functions being run." | ||
| 6789 | (interactive "P") | 7245 | (interactive "P") |
| 6790 | (if (not arg) | 7246 | (cond |
| 6791 | ;; Select the article the normal way. | 7247 | ((numberp arg) |
| 6792 | (gnus-summary-select-article nil 'force) | 7248 | (let ((gnus-newsgroup-charset |
| 7249 | (or (cdr (assq arg gnus-summary-show-article-charset-alist)) | ||
| 7250 | (read-coding-system "Charset: "))) | ||
| 7251 | (gnus-newsgroup-ignored-charsets 'gnus-all)) | ||
| 7252 | (gnus-summary-select-article nil 'force))) | ||
| 7253 | ((not arg) | ||
| 7254 | ;; Select the article the normal way. | ||
| 7255 | (gnus-summary-select-article nil 'force)) | ||
| 7256 | (t | ||
| 7257 | ;; We have to require this here to make sure that the following | ||
| 7258 | ;; dynamic binding isn't shadowed by autoloading. | ||
| 7259 | (require 'gnus-async) | ||
| 7260 | (require 'gnus-art) | ||
| 6793 | ;; Bind the article treatment functions to nil. | 7261 | ;; Bind the article treatment functions to nil. |
| 6794 | (let ((gnus-have-all-headers t) | 7262 | (let ((gnus-have-all-headers t) |
| 6795 | gnus-article-display-hook | ||
| 6796 | gnus-article-prepare-hook | 7263 | gnus-article-prepare-hook |
| 6797 | gnus-break-pages | 7264 | gnus-article-decode-hook |
| 6798 | gnus-show-mime | 7265 | gnus-display-mime-function |
| 6799 | gnus-visual) | 7266 | gnus-break-pages) |
| 6800 | (gnus-summary-select-article nil 'force))) | 7267 | ;; Destroy any MIME parts. |
| 7268 | (when (gnus-buffer-live-p gnus-article-buffer) | ||
| 7269 | (save-excursion | ||
| 7270 | (set-buffer gnus-article-buffer) | ||
| 7271 | (mm-destroy-parts gnus-article-mime-handles) | ||
| 7272 | ;; Set it to nil for safety reason. | ||
| 7273 | (setq gnus-article-mime-handle-alist nil) | ||
| 7274 | (setq gnus-article-mime-handles nil))) | ||
| 7275 | (gnus-summary-select-article nil 'force)))) | ||
| 6801 | (gnus-summary-goto-subject gnus-current-article) | 7276 | (gnus-summary-goto-subject gnus-current-article) |
| 6802 | (gnus-summary-position-point)) | 7277 | (gnus-summary-position-point)) |
| 6803 | 7278 | ||
| @@ -6821,40 +7296,42 @@ If ARG is a negative number, hide the unwanted header lines." | |||
| 6821 | (interactive "P") | 7296 | (interactive "P") |
| 6822 | (save-excursion | 7297 | (save-excursion |
| 6823 | (set-buffer gnus-article-buffer) | 7298 | (set-buffer gnus-article-buffer) |
| 6824 | (let* ((buffer-read-only nil) | 7299 | (save-restriction |
| 6825 | (inhibit-point-motion-hooks t) | 7300 | (let* ((buffer-read-only nil) |
| 6826 | (hidden (text-property-any | 7301 | (inhibit-point-motion-hooks t) |
| 6827 | (goto-char (point-min)) (search-forward "\n\n") | 7302 | hidden e) |
| 6828 | 'invisible t)) | 7303 | (setq hidden |
| 6829 | e) | 7304 | (if (numberp arg) |
| 6830 | (goto-char (point-min)) | 7305 | (>= arg 0) |
| 6831 | (when (search-forward "\n\n" nil t) | 7306 | (save-restriction |
| 6832 | (delete-region (point-min) (1- (point)))) | 7307 | (article-narrow-to-head) |
| 6833 | (goto-char (point-min)) | 7308 | (gnus-article-hidden-text-p 'headers)))) |
| 6834 | (save-excursion | ||
| 6835 | (set-buffer gnus-original-article-buffer) | ||
| 6836 | (goto-char (point-min)) | 7309 | (goto-char (point-min)) |
| 6837 | (setq e (1- (or (search-forward "\n\n" nil t) (point-max))))) | 7310 | (when (search-forward "\n\n" nil t) |
| 6838 | (insert-buffer-substring gnus-original-article-buffer 1 e) | 7311 | (delete-region (point-min) (1- (point)))) |
| 6839 | (let ((article-inhibit-hiding t)) | 7312 | (goto-char (point-min)) |
| 6840 | (gnus-run-hooks 'gnus-article-display-hook)) | 7313 | (save-excursion |
| 6841 | (when (or (not hidden) (and (numberp arg) (< arg 0))) | 7314 | (set-buffer gnus-original-article-buffer) |
| 6842 | (gnus-article-hide-headers))))) | 7315 | (goto-char (point-min)) |
| 7316 | (setq e (1- (or (search-forward "\n\n" nil t) (point-max))))) | ||
| 7317 | (insert-buffer-substring gnus-original-article-buffer 1 e) | ||
| 7318 | (save-restriction | ||
| 7319 | (narrow-to-region (point-min) (point)) | ||
| 7320 | (article-decode-encoded-words) | ||
| 7321 | (if hidden | ||
| 7322 | (let ((gnus-treat-hide-headers nil) | ||
| 7323 | (gnus-treat-hide-boring-headers nil)) | ||
| 7324 | (setq gnus-article-wash-types | ||
| 7325 | (delq 'headers gnus-article-wash-types)) | ||
| 7326 | (gnus-treat-article 'head)) | ||
| 7327 | (gnus-treat-article 'head))) | ||
| 7328 | (gnus-set-mode-line 'article))))) | ||
| 6843 | 7329 | ||
| 6844 | (defun gnus-summary-show-all-headers () | 7330 | (defun gnus-summary-show-all-headers () |
| 6845 | "Make all header lines visible." | 7331 | "Make all header lines visible." |
| 6846 | (interactive) | 7332 | (interactive) |
| 6847 | (gnus-article-show-all-headers)) | 7333 | (gnus-article-show-all-headers)) |
| 6848 | 7334 | ||
| 6849 | (defun gnus-summary-toggle-mime (&optional arg) | ||
| 6850 | "Toggle MIME processing. | ||
| 6851 | If ARG is a positive number, turn MIME processing on." | ||
| 6852 | (interactive "P") | ||
| 6853 | (setq gnus-show-mime | ||
| 6854 | (if (null arg) (not gnus-show-mime) | ||
| 6855 | (> (prefix-numeric-value arg) 0))) | ||
| 6856 | (gnus-summary-select-article t 'force)) | ||
| 6857 | |||
| 6858 | (defun gnus-summary-caesar-message (&optional arg) | 7335 | (defun gnus-summary-caesar-message (&optional arg) |
| 6859 | "Caesar rotate the current article by 13. | 7336 | "Caesar rotate the current article by 13. |
| 6860 | The numerical prefix specifies how many places to rotate each letter | 7337 | The numerical prefix specifies how many places to rotate each letter |
| @@ -6895,7 +7372,9 @@ re-spool using this method. | |||
| 6895 | 7372 | ||
| 6896 | For this function to work, both the current newsgroup and the | 7373 | For this function to work, both the current newsgroup and the |
| 6897 | newsgroup that you want to move to have to support the `request-move' | 7374 | newsgroup that you want to move to have to support the `request-move' |
| 6898 | and `request-accept' functions." | 7375 | and `request-accept' functions. |
| 7376 | |||
| 7377 | ACTION can be either `move' (the default), `crosspost' or `copy'." | ||
| 6899 | (interactive "P") | 7378 | (interactive "P") |
| 6900 | (unless action | 7379 | (unless action |
| 6901 | (setq action 'move)) | 7380 | (setq action 'move)) |
| @@ -6913,7 +7392,10 @@ and `request-accept' functions." | |||
| 6913 | 'request-replace-article gnus-newsgroup-name))) | 7392 | 'request-replace-article gnus-newsgroup-name))) |
| 6914 | (error "The current group does not support article editing"))) | 7393 | (error "The current group does not support article editing"))) |
| 6915 | (let ((articles (gnus-summary-work-articles n)) | 7394 | (let ((articles (gnus-summary-work-articles n)) |
| 6916 | (prefix (gnus-group-real-prefix gnus-newsgroup-name)) | 7395 | (prefix (if (gnus-check-backend-function |
| 7396 | 'request-move-article gnus-newsgroup-name) | ||
| 7397 | (gnus-group-real-prefix gnus-newsgroup-name) | ||
| 7398 | "")) | ||
| 6917 | (names '((move "Move" "Moving") | 7399 | (names '((move "Move" "Moving") |
| 6918 | (copy "Copy" "Copying") | 7400 | (copy "Copy" "Copying") |
| 6919 | (crosspost "Crosspost" "Crossposting"))) | 7401 | (crosspost "Crosspost" "Crossposting"))) |
| @@ -6932,7 +7414,8 @@ and `request-accept' functions." | |||
| 6932 | articles prefix)) | 7414 | articles prefix)) |
| 6933 | (set (intern (format "gnus-current-%s-group" action)) to-newsgroup)) | 7415 | (set (intern (format "gnus-current-%s-group" action)) to-newsgroup)) |
| 6934 | (setq to-method (or select-method | 7416 | (setq to-method (or select-method |
| 6935 | (gnus-group-name-to-method to-newsgroup))) | 7417 | (gnus-server-to-method |
| 7418 | (gnus-group-method to-newsgroup)))) | ||
| 6936 | ;; Check the method we are to move this article to... | 7419 | ;; Check the method we are to move this article to... |
| 6937 | (unless (gnus-check-backend-function | 7420 | (unless (gnus-check-backend-function |
| 6938 | 'request-accept-article (car to-method)) | 7421 | 'request-accept-article (car to-method)) |
| @@ -6958,7 +7441,7 @@ and `request-accept' functions." | |||
| 6958 | gnus-newsgroup-name)) ; Server | 7441 | gnus-newsgroup-name)) ; Server |
| 6959 | (list 'gnus-request-accept-article | 7442 | (list 'gnus-request-accept-article |
| 6960 | to-newsgroup (list 'quote select-method) | 7443 | to-newsgroup (list 'quote select-method) |
| 6961 | (not articles)) ; Accept form | 7444 | (not articles) t) ; Accept form |
| 6962 | (not articles))) ; Only save nov last time | 7445 | (not articles))) ; Only save nov last time |
| 6963 | ;; Copy the article. | 7446 | ;; Copy the article. |
| 6964 | ((eq action 'copy) | 7447 | ((eq action 'copy) |
| @@ -6966,7 +7449,7 @@ and `request-accept' functions." | |||
| 6966 | (set-buffer copy-buf) | 7449 | (set-buffer copy-buf) |
| 6967 | (when (gnus-request-article-this-buffer article gnus-newsgroup-name) | 7450 | (when (gnus-request-article-this-buffer article gnus-newsgroup-name) |
| 6968 | (gnus-request-accept-article | 7451 | (gnus-request-accept-article |
| 6969 | to-newsgroup select-method (not articles))))) | 7452 | to-newsgroup select-method (not articles) t)))) |
| 6970 | ;; Crosspost the article. | 7453 | ;; Crosspost the article. |
| 6971 | ((eq action 'crosspost) | 7454 | ((eq action 'crosspost) |
| 6972 | (let ((xref (message-tokenize-header | 7455 | (let ((xref (message-tokenize-header |
| @@ -6999,19 +7482,21 @@ and `request-accept' functions." | |||
| 6999 | art-group)))))) | 7482 | art-group)))))) |
| 7000 | (cond | 7483 | (cond |
| 7001 | ((not art-group) | 7484 | ((not art-group) |
| 7002 | (gnus-message 1 "Couldn't %s article %s" | 7485 | (gnus-message 1 "Couldn't %s article %s: %s" |
| 7003 | (cadr (assq action names)) article)) | 7486 | (cadr (assq action names)) article |
| 7004 | ((and (eq art-group 'junk) | 7487 | (nnheader-get-report (car to-method)))) |
| 7005 | (eq action 'move)) | 7488 | ((eq art-group 'junk) |
| 7006 | (gnus-summary-mark-article article gnus-canceled-mark) | 7489 | (when (eq action 'move) |
| 7007 | (gnus-message 4 "Deleted article %s" article)) | 7490 | (gnus-summary-mark-article article gnus-canceled-mark) |
| 7491 | (gnus-message 4 "Deleted article %s" article))) | ||
| 7008 | (t | 7492 | (t |
| 7009 | (let* ((pto-group (gnus-group-prefixed-name | 7493 | (let* ((pto-group (gnus-group-prefixed-name |
| 7010 | (car art-group) to-method)) | 7494 | (car art-group) to-method)) |
| 7011 | (entry | 7495 | (entry |
| 7012 | (gnus-gethash pto-group gnus-newsrc-hashtb)) | 7496 | (gnus-gethash pto-group gnus-newsrc-hashtb)) |
| 7013 | (info (nth 2 entry)) | 7497 | (info (nth 2 entry)) |
| 7014 | (to-group (gnus-info-group info))) | 7498 | (to-group (gnus-info-group info)) |
| 7499 | to-marks) | ||
| 7015 | ;; Update the group that has been moved to. | 7500 | ;; Update the group that has been moved to. |
| 7016 | (when (and info | 7501 | (when (and info |
| 7017 | (memq action '(move copy))) | 7502 | (memq action '(move copy))) |
| @@ -7019,49 +7504,54 @@ and `request-accept' functions." | |||
| 7019 | (push to-group to-groups)) | 7504 | (push to-group to-groups)) |
| 7020 | 7505 | ||
| 7021 | (unless (memq article gnus-newsgroup-unreads) | 7506 | (unless (memq article gnus-newsgroup-unreads) |
| 7507 | (push 'read to-marks) | ||
| 7022 | (gnus-info-set-read | 7508 | (gnus-info-set-read |
| 7023 | info (gnus-add-to-range (gnus-info-read info) | 7509 | info (gnus-add-to-range (gnus-info-read info) |
| 7024 | (list (cdr art-group))))) | 7510 | (list (cdr art-group))))) |
| 7025 | 7511 | ||
| 7026 | ;; Copy any marks over to the new group. | 7512 | ;; See whether the article is to be put in the cache. |
| 7027 | (let ((marks gnus-article-mark-lists) | 7513 | (let ((marks gnus-article-mark-lists) |
| 7028 | (to-article (cdr art-group))) | 7514 | (to-article (cdr art-group))) |
| 7029 | 7515 | ||
| 7030 | ;; See whether the article is to be put in the cache. | 7516 | ;; Enter the article into the cache in the new group, |
| 7517 | ;; if that is required. | ||
| 7031 | (when gnus-use-cache | 7518 | (when gnus-use-cache |
| 7032 | (gnus-cache-possibly-enter-article | 7519 | (gnus-cache-possibly-enter-article |
| 7033 | to-group to-article | 7520 | to-group to-article |
| 7034 | (let ((header (copy-sequence | ||
| 7035 | (gnus-summary-article-header article)))) | ||
| 7036 | (mail-header-set-number header to-article) | ||
| 7037 | header) | ||
| 7038 | (memq article gnus-newsgroup-marked) | 7521 | (memq article gnus-newsgroup-marked) |
| 7039 | (memq article gnus-newsgroup-dormant) | 7522 | (memq article gnus-newsgroup-dormant) |
| 7040 | (memq article gnus-newsgroup-unreads))) | 7523 | (memq article gnus-newsgroup-unreads))) |
| 7041 | 7524 | ||
| 7042 | (when (and (equal to-group gnus-newsgroup-name) | 7525 | (when gnus-preserve-marks |
| 7043 | (not (memq article gnus-newsgroup-unreads))) | 7526 | ;; Copy any marks over to the new group. |
| 7044 | ;; Mark this article as read in this group. | 7527 | (when (and (equal to-group gnus-newsgroup-name) |
| 7045 | (push (cons to-article gnus-read-mark) gnus-newsgroup-reads) | 7528 | (not (memq article gnus-newsgroup-unreads))) |
| 7046 | (setcdr (gnus-active to-group) to-article) | 7529 | ;; Mark this article as read in this group. |
| 7047 | (setcdr gnus-newsgroup-active to-article)) | 7530 | (push (cons to-article gnus-read-mark) gnus-newsgroup-reads) |
| 7048 | 7531 | (setcdr (gnus-active to-group) to-article) | |
| 7049 | (while marks | 7532 | (setcdr gnus-newsgroup-active to-article)) |
| 7050 | (when (memq article (symbol-value | 7533 | |
| 7051 | (intern (format "gnus-newsgroup-%s" | 7534 | (while marks |
| 7052 | (caar marks))))) | 7535 | (when (memq article (symbol-value |
| 7053 | ;; If the other group is the same as this group, | 7536 | (intern (format "gnus-newsgroup-%s" |
| 7054 | ;; then we have to add the mark to the list. | 7537 | (caar marks))))) |
| 7055 | (when (equal to-group gnus-newsgroup-name) | 7538 | (push (cdar marks) to-marks) |
| 7056 | (set (intern (format "gnus-newsgroup-%s" (caar marks))) | 7539 | ;; If the other group is the same as this group, |
| 7057 | (cons to-article | 7540 | ;; then we have to add the mark to the list. |
| 7058 | (symbol-value | 7541 | (when (equal to-group gnus-newsgroup-name) |
| 7059 | (intern (format "gnus-newsgroup-%s" | 7542 | (set (intern (format "gnus-newsgroup-%s" (caar marks))) |
| 7060 | (caar marks))))))) | 7543 | (cons to-article |
| 7061 | ;; Copy the marks to other group. | 7544 | (symbol-value |
| 7062 | (gnus-add-marked-articles | 7545 | (intern (format "gnus-newsgroup-%s" |
| 7063 | to-group (cdar marks) (list to-article) info)) | 7546 | (caar marks))))))) |
| 7064 | (setq marks (cdr marks))) | 7547 | ;; Copy the marks to other group. |
| 7548 | (gnus-add-marked-articles | ||
| 7549 | to-group (cdar marks) (list to-article) info)) | ||
| 7550 | (setq marks (cdr marks))) | ||
| 7551 | |||
| 7552 | (gnus-request-set-mark to-group (list (list (list to-article) | ||
| 7553 | 'set | ||
| 7554 | to-marks)))) | ||
| 7065 | 7555 | ||
| 7066 | (gnus-dribble-enter | 7556 | (gnus-dribble-enter |
| 7067 | (concat "(gnus-group-set-info '" | 7557 | (concat "(gnus-group-set-info '" |
| @@ -7174,9 +7664,8 @@ latter case, they will be copied into the relevant groups." | |||
| 7174 | (error "Can't read %s" file)) | 7664 | (error "Can't read %s" file)) |
| 7175 | (save-excursion | 7665 | (save-excursion |
| 7176 | (set-buffer (gnus-get-buffer-create " *import file*")) | 7666 | (set-buffer (gnus-get-buffer-create " *import file*")) |
| 7177 | (buffer-disable-undo (current-buffer)) | ||
| 7178 | (erase-buffer) | 7667 | (erase-buffer) |
| 7179 | (insert-file-contents file) | 7668 | (nnheader-insert-file-contents file) |
| 7180 | (goto-char (point-min)) | 7669 | (goto-char (point-min)) |
| 7181 | (unless (nnheader-article-p) | 7670 | (unless (nnheader-article-p) |
| 7182 | ;; This doesn't look like an article, so we fudge some headers. | 7671 | ;; This doesn't look like an article, so we fudge some headers. |
| @@ -7184,10 +7673,7 @@ latter case, they will be copied into the relevant groups." | |||
| 7184 | lines (count-lines (point-min) (point-max))) | 7673 | lines (count-lines (point-min) (point-max))) |
| 7185 | (insert "From: " (read-string "From: ") "\n" | 7674 | (insert "From: " (read-string "From: ") "\n" |
| 7186 | "Subject: " (read-string "Subject: ") "\n" | 7675 | "Subject: " (read-string "Subject: ") "\n" |
| 7187 | "Date: " (timezone-make-date-arpa-standard | 7676 | "Date: " (message-make-date (nth 5 atts)) |
| 7188 | (current-time-string (nth 5 atts)) | ||
| 7189 | (current-time-zone now) | ||
| 7190 | (current-time-zone now)) | ||
| 7191 | "\n" | 7677 | "\n" |
| 7192 | "Message-ID: " (message-make-message-id) "\n" | 7678 | "Message-ID: " (message-make-message-id) "\n" |
| 7193 | "Lines: " (int-to-string lines) "\n" | 7679 | "Lines: " (int-to-string lines) "\n" |
| @@ -7196,12 +7682,11 @@ latter case, they will be copied into the relevant groups." | |||
| 7196 | (kill-buffer (current-buffer))))) | 7682 | (kill-buffer (current-buffer))))) |
| 7197 | 7683 | ||
| 7198 | (defun gnus-summary-article-posted-p () | 7684 | (defun gnus-summary-article-posted-p () |
| 7199 | "Say whether the current (mail) article is available from `gnus-select-method' as well. | 7685 | "Say whether the current (mail) article is available from news as well. |
| 7200 | This will be the case if the article has both been mailed and posted." | 7686 | This will be the case if the article has both been mailed and posted." |
| 7201 | (interactive) | 7687 | (interactive) |
| 7202 | (let ((id (mail-header-references (gnus-summary-article-header))) | 7688 | (let ((id (mail-header-references (gnus-summary-article-header))) |
| 7203 | (gnus-override-method | 7689 | (gnus-override-method (car (gnus-refer-article-methods)))) |
| 7204 | (or gnus-refer-article-method gnus-select-method))) | ||
| 7205 | (if (gnus-request-head id "") | 7690 | (if (gnus-request-head id "") |
| 7206 | (gnus-message 2 "The current message was found on %s" | 7691 | (gnus-message 2 "The current message was found on %s" |
| 7207 | gnus-override-method) | 7692 | gnus-override-method) |
| @@ -7229,11 +7714,16 @@ This will be the case if the article has both been mailed and posted." | |||
| 7229 | (expiry-wait (if now 'immediate | 7714 | (expiry-wait (if now 'immediate |
| 7230 | (gnus-group-find-parameter | 7715 | (gnus-group-find-parameter |
| 7231 | gnus-newsgroup-name 'expiry-wait))) | 7716 | gnus-newsgroup-name 'expiry-wait))) |
| 7717 | (nnmail-expiry-target | ||
| 7718 | (or (gnus-group-find-parameter gnus-newsgroup-name 'expiry-target) | ||
| 7719 | nnmail-expiry-target)) | ||
| 7232 | es) | 7720 | es) |
| 7233 | (when expirable | 7721 | (when expirable |
| 7234 | ;; There are expirable articles in this group, so we run them | 7722 | ;; There are expirable articles in this group, so we run them |
| 7235 | ;; through the expiry process. | 7723 | ;; through the expiry process. |
| 7236 | (gnus-message 6 "Expiring articles...") | 7724 | (gnus-message 6 "Expiring articles...") |
| 7725 | (unless (gnus-check-group gnus-newsgroup-name) | ||
| 7726 | (error "Can't open server for %s" gnus-newsgroup-name)) | ||
| 7237 | ;; The list of articles that weren't expired is returned. | 7727 | ;; The list of articles that weren't expired is returned. |
| 7238 | (save-excursion | 7728 | (save-excursion |
| 7239 | (if expiry-wait | 7729 | (if expiry-wait |
| @@ -7281,6 +7771,8 @@ delete these instead." | |||
| 7281 | (unless (gnus-check-backend-function 'request-expire-articles | 7771 | (unless (gnus-check-backend-function 'request-expire-articles |
| 7282 | gnus-newsgroup-name) | 7772 | gnus-newsgroup-name) |
| 7283 | (error "The current newsgroup does not support article deletion")) | 7773 | (error "The current newsgroup does not support article deletion")) |
| 7774 | (unless (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name)) | ||
| 7775 | (error "Couldn't open server")) | ||
| 7284 | ;; Compute the list of articles to delete. | 7776 | ;; Compute the list of articles to delete. |
| 7285 | (let ((articles (sort (copy-sequence (gnus-summary-work-articles n)) '<)) | 7777 | (let ((articles (sort (copy-sequence (gnus-summary-work-articles n)) '<)) |
| 7286 | not-deleted) | 7778 | not-deleted) |
| @@ -7307,28 +7799,63 @@ delete these instead." | |||
| 7307 | (gnus-set-mode-line 'summary) | 7799 | (gnus-set-mode-line 'summary) |
| 7308 | not-deleted)) | 7800 | not-deleted)) |
| 7309 | 7801 | ||
| 7310 | (defun gnus-summary-edit-article (&optional force) | 7802 | (defun gnus-summary-edit-article (&optional arg) |
| 7311 | "Edit the current article. | 7803 | "Edit the current article. |
| 7312 | This will have permanent effect only in mail groups. | 7804 | This will have permanent effect only in mail groups. |
| 7313 | If FORCE is non-nil, allow editing of articles even in read-only | 7805 | If ARG is nil, edit the decoded articles. |
| 7806 | If ARG is 1, edit the raw articles. | ||
| 7807 | If ARG is 2, edit the raw articles even in read-only groups. | ||
| 7808 | Otherwise, allow editing of articles even in read-only | ||
| 7314 | groups." | 7809 | groups." |
| 7315 | (interactive "P") | 7810 | (interactive "P") |
| 7316 | (save-excursion | 7811 | (let (force raw) |
| 7317 | (set-buffer gnus-summary-buffer) | 7812 | (cond |
| 7318 | (gnus-set-global-variables) | 7813 | ((null arg)) |
| 7319 | (when (and (not force) | 7814 | ((eq arg 1) (setq raw t)) |
| 7320 | (gnus-group-read-only-p)) | 7815 | ((eq arg 2) (setq raw t |
| 7321 | (error "The current newsgroup does not support article editing")) | 7816 | force t)) |
| 7322 | ;; Select article if needed. | 7817 | (t (setq force t))) |
| 7323 | (unless (eq (gnus-summary-article-number) | 7818 | (if (and raw (not force) (equal gnus-newsgroup-name "nndraft:drafts")) |
| 7324 | gnus-current-article) | 7819 | (error "Can't edit the raw article in group nndraft:drafts.")) |
| 7325 | (gnus-summary-select-article t)) | 7820 | (save-excursion |
| 7326 | (gnus-article-date-original) | 7821 | (set-buffer gnus-summary-buffer) |
| 7327 | (gnus-article-edit-article | 7822 | (let ((mail-parse-charset gnus-newsgroup-charset) |
| 7328 | `(lambda (no-highlight) | 7823 | (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets)) |
| 7329 | (gnus-summary-edit-article-done | 7824 | (gnus-set-global-variables) |
| 7330 | ,(or (mail-header-references gnus-current-headers) "") | 7825 | (when (and (not force) |
| 7331 | ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight))))) | 7826 | (gnus-group-read-only-p)) |
| 7827 | (error "The current newsgroup does not support article editing")) | ||
| 7828 | (gnus-summary-show-article t) | ||
| 7829 | (when (and (not raw) (gnus-buffer-live-p gnus-article-buffer)) | ||
| 7830 | (with-current-buffer gnus-article-buffer | ||
| 7831 | (mm-enable-multibyte))) | ||
| 7832 | (if (equal gnus-newsgroup-name "nndraft:drafts") | ||
| 7833 | (setq raw t)) | ||
| 7834 | (gnus-article-edit-article | ||
| 7835 | (if raw 'ignore | ||
| 7836 | #'(lambda () | ||
| 7837 | (let ((mbl mml-buffer-list)) | ||
| 7838 | (setq mml-buffer-list nil) | ||
| 7839 | (mime-to-mml) | ||
| 7840 | (make-local-hook 'kill-buffer-hook) | ||
| 7841 | (let ((mml-buffer-list mml-buffer-list)) | ||
| 7842 | (setq mml-buffer-list mbl) | ||
| 7843 | (make-local-variable 'mml-buffer-list)) | ||
| 7844 | (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t)))) | ||
| 7845 | `(lambda (no-highlight) | ||
| 7846 | (let ((mail-parse-charset ',gnus-newsgroup-charset) | ||
| 7847 | (mail-parse-ignored-charsets | ||
| 7848 | ',gnus-newsgroup-ignored-charsets)) | ||
| 7849 | ,(if (not raw) '(progn | ||
| 7850 | (mml-to-mime) | ||
| 7851 | (mml-destroy-buffers) | ||
| 7852 | (remove-hook 'kill-buffer-hook | ||
| 7853 | 'mml-destroy-buffers t) | ||
| 7854 | (kill-local-variable 'mml-buffer-list))) | ||
| 7855 | (gnus-summary-edit-article-done | ||
| 7856 | ,(or (mail-header-references gnus-current-headers) "") | ||
| 7857 | ,(gnus-group-read-only-p) | ||
| 7858 | ,gnus-summary-buffer no-highlight)))))))) | ||
| 7332 | 7859 | ||
| 7333 | (defalias 'gnus-summary-edit-article-postpone 'gnus-article-edit-exit) | 7860 | (defalias 'gnus-summary-edit-article-postpone 'gnus-article-edit-exit) |
| 7334 | 7861 | ||
| @@ -7338,12 +7865,12 @@ groups." | |||
| 7338 | (interactive) | 7865 | (interactive) |
| 7339 | ;; Replace the article. | 7866 | ;; Replace the article. |
| 7340 | (let ((buf (current-buffer))) | 7867 | (let ((buf (current-buffer))) |
| 7341 | (nnheader-temp-write nil | 7868 | (with-temp-buffer |
| 7342 | (insert-buffer buf) | 7869 | (insert-buffer-substring buf) |
| 7343 | (if (and (not read-only) | 7870 | (if (and (not read-only) |
| 7344 | (not (gnus-request-replace-article | 7871 | (not (gnus-request-replace-article |
| 7345 | (cdr gnus-article-current) (car gnus-article-current) | 7872 | (cdr gnus-article-current) (car gnus-article-current) |
| 7346 | (current-buffer)))) | 7873 | (current-buffer) t))) |
| 7347 | (error "Couldn't replace article") | 7874 | (error "Couldn't replace article") |
| 7348 | ;; Update the summary buffer. | 7875 | ;; Update the summary buffer. |
| 7349 | (if (and references | 7876 | (if (and references |
| @@ -7356,7 +7883,7 @@ groups." | |||
| 7356 | (message-narrow-to-head) | 7883 | (message-narrow-to-head) |
| 7357 | (let ((head (buffer-string)) | 7884 | (let ((head (buffer-string)) |
| 7358 | header) | 7885 | header) |
| 7359 | (nnheader-temp-write nil | 7886 | (with-temp-buffer |
| 7360 | (insert (format "211 %d Article retrieved.\n" | 7887 | (insert (format "211 %d Article retrieved.\n" |
| 7361 | (cdr gnus-article-current))) | 7888 | (cdr gnus-article-current))) |
| 7362 | (insert head) | 7889 | (insert head) |
| @@ -7381,7 +7908,8 @@ groups." | |||
| 7381 | (unless no-highlight | 7908 | (unless no-highlight |
| 7382 | (save-excursion | 7909 | (save-excursion |
| 7383 | (set-buffer gnus-article-buffer) | 7910 | (set-buffer gnus-article-buffer) |
| 7384 | (gnus-run-hooks 'gnus-article-display-hook) | 7911 | ;;;!!! Fix this -- article should be rehighlighted. |
| 7912 | ;;;(gnus-run-hooks 'gnus-article-display-hook) | ||
| 7385 | (set-buffer gnus-original-article-buffer) | 7913 | (set-buffer gnus-original-article-buffer) |
| 7386 | (gnus-request-article | 7914 | (gnus-request-article |
| 7387 | (cdr gnus-article-current) | 7915 | (cdr gnus-article-current) |
| @@ -7544,7 +8072,7 @@ the actual number of articles marked is returned." | |||
| 7544 | "Mark ARTICLE replied and update the summary line." | 8072 | "Mark ARTICLE replied and update the summary line." |
| 7545 | (push article gnus-newsgroup-replied) | 8073 | (push article gnus-newsgroup-replied) |
| 7546 | (let ((buffer-read-only nil)) | 8074 | (let ((buffer-read-only nil)) |
| 7547 | (when (gnus-summary-goto-subject article) | 8075 | (when (gnus-summary-goto-subject article nil t) |
| 7548 | (gnus-summary-update-secondary-mark article)))) | 8076 | (gnus-summary-update-secondary-mark article)))) |
| 7549 | 8077 | ||
| 7550 | (defun gnus-summary-set-bookmark (article) | 8078 | (defun gnus-summary-set-bookmark (article) |
| @@ -7624,8 +8152,10 @@ the actual number of articles marked is returned." | |||
| 7624 | "Mark N articles as read forwards. | 8152 | "Mark N articles as read forwards. |
| 7625 | If N is negative, mark backwards instead. Mark with MARK, ?r by default. | 8153 | If N is negative, mark backwards instead. Mark with MARK, ?r by default. |
| 7626 | The difference between N and the actual number of articles marked is | 8154 | The difference between N and the actual number of articles marked is |
| 7627 | returned." | 8155 | returned. |
| 8156 | Iff NO-EXPIRE, auto-expiry will be inhibited." | ||
| 7628 | (interactive "p") | 8157 | (interactive "p") |
| 8158 | (gnus-summary-show-thread) | ||
| 7629 | (let ((backward (< n 0)) | 8159 | (let ((backward (< n 0)) |
| 7630 | (gnus-summary-goto-unread | 8160 | (gnus-summary-goto-unread |
| 7631 | (and gnus-summary-goto-unread | 8161 | (and gnus-summary-goto-unread |
| @@ -7663,11 +8193,7 @@ returned." | |||
| 7663 | (setq mark (gnus-request-update-mark gnus-newsgroup-name article mark)) | 8193 | (setq mark (gnus-request-update-mark gnus-newsgroup-name article mark)) |
| 7664 | ;; Check for auto-expiry. | 8194 | ;; Check for auto-expiry. |
| 7665 | (when (and gnus-newsgroup-auto-expire | 8195 | (when (and gnus-newsgroup-auto-expire |
| 7666 | (or (= mark gnus-killed-mark) (= mark gnus-del-mark) | 8196 | (memq mark gnus-auto-expirable-marks)) |
| 7667 | (= mark gnus-catchup-mark) (= mark gnus-low-score-mark) | ||
| 7668 | (= mark gnus-ancient-mark) | ||
| 7669 | (= mark gnus-read-mark) (= mark gnus-souped-mark) | ||
| 7670 | (= mark gnus-duplicate-mark))) | ||
| 7671 | (setq mark gnus-expirable-mark) | 8197 | (setq mark gnus-expirable-mark) |
| 7672 | ;; Let the backend know about the mark change. | 8198 | ;; Let the backend know about the mark change. |
| 7673 | (setq mark (gnus-request-update-mark gnus-newsgroup-name article mark)) | 8199 | (setq mark (gnus-request-update-mark gnus-newsgroup-name article mark)) |
| @@ -7706,7 +8232,6 @@ returned." | |||
| 7706 | (save-excursion | 8232 | (save-excursion |
| 7707 | (gnus-cache-possibly-enter-article | 8233 | (gnus-cache-possibly-enter-article |
| 7708 | gnus-newsgroup-name article | 8234 | gnus-newsgroup-name article |
| 7709 | (gnus-summary-article-header article) | ||
| 7710 | (= mark gnus-ticked-mark) | 8235 | (= mark gnus-ticked-mark) |
| 7711 | (= mark gnus-dormant-mark) (= mark gnus-unread-mark)))) | 8236 | (= mark gnus-dormant-mark) (= mark gnus-unread-mark)))) |
| 7712 | 8237 | ||
| @@ -7718,25 +8243,22 @@ returned." | |||
| 7718 | "Mark ARTICLE with MARK. MARK can be any character. | 8243 | "Mark ARTICLE with MARK. MARK can be any character. |
| 7719 | Four MARK strings are reserved: `? ' (unread), `?!' (ticked), | 8244 | Four MARK strings are reserved: `? ' (unread), `?!' (ticked), |
| 7720 | `??' (dormant) and `?E' (expirable). | 8245 | `??' (dormant) and `?E' (expirable). |
| 7721 | If MARK is nil, then the default character `?D' is used. | 8246 | If MARK is nil, then the default character `?r' is used. |
| 7722 | If ARTICLE is nil, then the article on the current line will be | 8247 | If ARTICLE is nil, then the article on the current line will be |
| 7723 | marked." | 8248 | marked. |
| 8249 | Iff NO-EXPIRE, auto-expiry will be inhibited." | ||
| 7724 | ;; The mark might be a string. | 8250 | ;; The mark might be a string. |
| 7725 | (when (stringp mark) | 8251 | (when (stringp mark) |
| 7726 | (setq mark (aref mark 0))) | 8252 | (setq mark (aref mark 0))) |
| 7727 | ;; If no mark is given, then we check auto-expiring. | 8253 | ;; If no mark is given, then we check auto-expiring. |
| 7728 | (and (not no-expire) | 8254 | (when (null mark) |
| 7729 | gnus-newsgroup-auto-expire | 8255 | (setq mark gnus-del-mark)) |
| 7730 | (or (not mark) | 8256 | (when (and (not no-expire) |
| 7731 | (and (gnus-characterp mark) | 8257 | gnus-newsgroup-auto-expire |
| 7732 | (or (= mark gnus-killed-mark) (= mark gnus-del-mark) | 8258 | (memq mark gnus-auto-expirable-marks)) |
| 7733 | (= mark gnus-catchup-mark) (= mark gnus-low-score-mark) | 8259 | (setq mark gnus-expirable-mark)) |
| 7734 | (= mark gnus-read-mark) (= mark gnus-souped-mark) | 8260 | (let ((article (or article (gnus-summary-article-number))) |
| 7735 | (= mark gnus-duplicate-mark)))) | 8261 | (old-mark (gnus-summary-article-mark article))) |
| 7736 | (setq mark gnus-expirable-mark)) | ||
| 7737 | (let* ((mark (or mark gnus-del-mark)) | ||
| 7738 | (article (or article (gnus-summary-article-number))) | ||
| 7739 | (old-mark (gnus-summary-article-mark article))) | ||
| 7740 | ;; Allow the backend to change the mark. | 8262 | ;; Allow the backend to change the mark. |
| 7741 | (setq mark (gnus-request-update-mark gnus-newsgroup-name article mark)) | 8263 | (setq mark (gnus-request-update-mark gnus-newsgroup-name article mark)) |
| 7742 | (if (eq mark old-mark) | 8264 | (if (eq mark old-mark) |
| @@ -7756,7 +8278,6 @@ marked." | |||
| 7756 | (save-excursion | 8278 | (save-excursion |
| 7757 | (gnus-cache-possibly-enter-article | 8279 | (gnus-cache-possibly-enter-article |
| 7758 | gnus-newsgroup-name article | 8280 | gnus-newsgroup-name article |
| 7759 | (gnus-summary-article-header article) | ||
| 7760 | (= mark gnus-ticked-mark) | 8281 | (= mark gnus-ticked-mark) |
| 7761 | (= mark gnus-dormant-mark) (= mark gnus-unread-mark)))) | 8282 | (= mark gnus-dormant-mark) (= mark gnus-unread-mark)))) |
| 7762 | 8283 | ||
| @@ -7788,19 +8309,19 @@ marked." | |||
| 7788 | (let ((forward (cdr (assq type gnus-summary-mark-positions))) | 8309 | (let ((forward (cdr (assq type gnus-summary-mark-positions))) |
| 7789 | (buffer-read-only nil)) | 8310 | (buffer-read-only nil)) |
| 7790 | (re-search-backward "[\n\r]" (gnus-point-at-bol) 'move-to-limit) | 8311 | (re-search-backward "[\n\r]" (gnus-point-at-bol) 'move-to-limit) |
| 7791 | (when (looking-at "\r") | 8312 | (when forward |
| 7792 | (incf forward)) | 8313 | (when (looking-at "\r") |
| 7793 | (when (and forward | 8314 | (incf forward)) |
| 7794 | (<= (+ forward (point)) (point-max))) | 8315 | (when (<= (+ forward (point)) (point-max)) |
| 7795 | ;; Go to the right position on the line. | 8316 | ;; Go to the right position on the line. |
| 7796 | (goto-char (+ forward (point))) | 8317 | (goto-char (+ forward (point))) |
| 7797 | ;; Replace the old mark with the new mark. | 8318 | ;; Replace the old mark with the new mark. |
| 7798 | (subst-char-in-region (point) (1+ (point)) (following-char) mark) | 8319 | (subst-char-in-region (point) (1+ (point)) (char-after) mark) |
| 7799 | ;; Optionally update the marks by some user rule. | 8320 | ;; Optionally update the marks by some user rule. |
| 7800 | (when (eq type 'unread) | 8321 | (when (eq type 'unread) |
| 7801 | (gnus-data-set-mark | 8322 | (gnus-data-set-mark |
| 7802 | (gnus-data-find (gnus-summary-article-number)) mark) | 8323 | (gnus-data-find (gnus-summary-article-number)) mark) |
| 7803 | (gnus-summary-update-line (eq mark gnus-unread-mark)))))) | 8324 | (gnus-summary-update-line (eq mark gnus-unread-mark))))))) |
| 7804 | 8325 | ||
| 7805 | (defun gnus-mark-article-as-read (article &optional mark) | 8326 | (defun gnus-mark-article-as-read (article &optional mark) |
| 7806 | "Enter ARTICLE in the pertinent lists and remove it from others." | 8327 | "Enter ARTICLE in the pertinent lists and remove it from others." |
| @@ -7881,14 +8402,15 @@ If N is negative, mark backwards instead. | |||
| 7881 | The difference between N and the actual number of articles marked is | 8402 | The difference between N and the actual number of articles marked is |
| 7882 | returned." | 8403 | returned." |
| 7883 | (interactive "p") | 8404 | (interactive "p") |
| 7884 | (gnus-summary-mark-forward n gnus-del-mark t)) | 8405 | (gnus-summary-mark-forward n gnus-del-mark gnus-inhibit-user-auto-expire)) |
| 7885 | 8406 | ||
| 7886 | (defun gnus-summary-mark-as-read-backward (n) | 8407 | (defun gnus-summary-mark-as-read-backward (n) |
| 7887 | "Mark the N articles as read backwards. | 8408 | "Mark the N articles as read backwards. |
| 7888 | The difference between N and the actual number of articles marked is | 8409 | The difference between N and the actual number of articles marked is |
| 7889 | returned." | 8410 | returned." |
| 7890 | (interactive "p") | 8411 | (interactive "p") |
| 7891 | (gnus-summary-mark-forward (- n) gnus-del-mark t)) | 8412 | (gnus-summary-mark-forward |
| 8413 | (- n) gnus-del-mark gnus-inhibit-user-auto-expire)) | ||
| 7892 | 8414 | ||
| 7893 | (defun gnus-summary-mark-as-read (&optional article mark) | 8415 | (defun gnus-summary-mark-as-read (&optional article mark) |
| 7894 | "Mark current article as read. | 8416 | "Mark current article as read. |
| @@ -8069,7 +8591,7 @@ If ALL is non-nil, also mark ticked and dormant articles as read." | |||
| 8069 | (gnus-summary-catchup t quietly)) | 8591 | (gnus-summary-catchup t quietly)) |
| 8070 | 8592 | ||
| 8071 | (defun gnus-summary-catchup-and-exit (&optional all quietly) | 8593 | (defun gnus-summary-catchup-and-exit (&optional all quietly) |
| 8072 | "Mark all articles not marked as unread in this newsgroup as read, then exit. | 8594 | "Mark all unread articles in this group as read, then exit. |
| 8073 | If prefix argument ALL is non-nil, all articles are marked as read." | 8595 | If prefix argument ALL is non-nil, all articles are marked as read." |
| 8074 | (interactive "P") | 8596 | (interactive "P") |
| 8075 | (when (gnus-summary-catchup all quietly nil 'fast) | 8597 | (when (gnus-summary-catchup all quietly nil 'fast) |
| @@ -8084,7 +8606,6 @@ If prefix argument ALL is non-nil, all articles are marked as read." | |||
| 8084 | (interactive "P") | 8606 | (interactive "P") |
| 8085 | (gnus-summary-catchup-and-exit t quietly)) | 8607 | (gnus-summary-catchup-and-exit t quietly)) |
| 8086 | 8608 | ||
| 8087 | ;; Suggested by "Arne Eofsson" <arne@hodgkin.mbi.ucla.edu>. | ||
| 8088 | (defun gnus-summary-catchup-and-goto-next-group (&optional all) | 8609 | (defun gnus-summary-catchup-and-goto-next-group (&optional all) |
| 8089 | "Mark all articles in this group as read and select the next group. | 8610 | "Mark all articles in this group as read and select the next group. |
| 8090 | If given a prefix, mark all articles, unread as well as ticked, as | 8611 | If given a prefix, mark all articles, unread as well as ticked, as |
| @@ -8092,7 +8613,38 @@ read." | |||
| 8092 | (interactive "P") | 8613 | (interactive "P") |
| 8093 | (save-excursion | 8614 | (save-excursion |
| 8094 | (gnus-summary-catchup all)) | 8615 | (gnus-summary-catchup all)) |
| 8095 | (gnus-summary-next-article t nil nil t)) | 8616 | (gnus-summary-next-group)) |
| 8617 | |||
| 8618 | ;;; | ||
| 8619 | ;;; with article | ||
| 8620 | ;;; | ||
| 8621 | |||
| 8622 | (defmacro gnus-with-article (article &rest forms) | ||
| 8623 | "Select ARTICLE and perform FORMS in the original article buffer. | ||
| 8624 | Then replace the article with the result." | ||
| 8625 | `(progn | ||
| 8626 | ;; We don't want the article to be marked as read. | ||
| 8627 | (let (gnus-mark-article-hook) | ||
| 8628 | (gnus-summary-select-article t t nil ,article)) | ||
| 8629 | (set-buffer gnus-original-article-buffer) | ||
| 8630 | ,@forms | ||
| 8631 | (if (not (gnus-check-backend-function | ||
| 8632 | 'request-replace-article (car gnus-article-current))) | ||
| 8633 | (gnus-message 5 "Read-only group; not replacing") | ||
| 8634 | (unless (gnus-request-replace-article | ||
| 8635 | ,article (car gnus-article-current) | ||
| 8636 | (current-buffer) t) | ||
| 8637 | (error "Couldn't replace article"))) | ||
| 8638 | ;; The cache and backlog have to be flushed somewhat. | ||
| 8639 | (when gnus-keep-backlog | ||
| 8640 | (gnus-backlog-remove-article | ||
| 8641 | (car gnus-article-current) (cdr gnus-article-current))) | ||
| 8642 | (when gnus-use-cache | ||
| 8643 | (gnus-cache-update-article | ||
| 8644 | (car gnus-article-current) (cdr gnus-article-current))))) | ||
| 8645 | |||
| 8646 | (put 'gnus-with-article 'lisp-indent-function 1) | ||
| 8647 | (put 'gnus-with-article 'edebug-form-spec '(form body)) | ||
| 8096 | 8648 | ||
| 8097 | ;; Thread-based commands. | 8649 | ;; Thread-based commands. |
| 8098 | 8650 | ||
| @@ -8171,25 +8723,17 @@ is non-nil or the Subject: of both articles are the same." | |||
| 8171 | (gnus-summary-article-header parent-article)))) | 8723 | (gnus-summary-article-header parent-article)))) |
| 8172 | (unless (and message-id (not (equal message-id ""))) | 8724 | (unless (and message-id (not (equal message-id ""))) |
| 8173 | (error "No message-id in desired parent")) | 8725 | (error "No message-id in desired parent")) |
| 8174 | ;; We don't want the article to be marked as read. | 8726 | (gnus-with-article current-article |
| 8175 | (let (gnus-mark-article-hook) | 8727 | (save-restriction |
| 8176 | (gnus-summary-select-article t t nil current-article)) | ||
| 8177 | (set-buffer gnus-original-article-buffer) | ||
| 8178 | (let ((buf (format "%s" (buffer-string)))) | ||
| 8179 | (nnheader-temp-write nil | ||
| 8180 | (insert buf) | ||
| 8181 | (goto-char (point-min)) | 8728 | (goto-char (point-min)) |
| 8729 | (message-narrow-to-head) | ||
| 8182 | (if (re-search-forward "^References: " nil t) | 8730 | (if (re-search-forward "^References: " nil t) |
| 8183 | (progn | 8731 | (progn |
| 8184 | (re-search-forward "^[^ \t]" nil t) | 8732 | (re-search-forward "^[^ \t]" nil t) |
| 8185 | (forward-line -1) | 8733 | (forward-line -1) |
| 8186 | (end-of-line) | 8734 | (end-of-line) |
| 8187 | (insert " " message-id)) | 8735 | (insert " " message-id)) |
| 8188 | (insert "References: " message-id "\n")) | 8736 | (insert "References: " message-id "\n")))) |
| 8189 | (unless (gnus-request-replace-article | ||
| 8190 | current-article (car gnus-article-current) | ||
| 8191 | (current-buffer)) | ||
| 8192 | (error "Couldn't replace article")))) | ||
| 8193 | (set-buffer gnus-summary-buffer) | 8737 | (set-buffer gnus-summary-buffer) |
| 8194 | (gnus-summary-unmark-all-processable) | 8738 | (gnus-summary-unmark-all-processable) |
| 8195 | (gnus-summary-update-article current-article) | 8739 | (gnus-summary-update-article current-article) |
| @@ -8264,9 +8808,7 @@ Returns nil if no threads were there to be hidden." | |||
| 8264 | (subst-char-in-region start (point) ?\n ?\^M) | 8808 | (subst-char-in-region start (point) ?\n ?\^M) |
| 8265 | (gnus-summary-goto-subject article)) | 8809 | (gnus-summary-goto-subject article)) |
| 8266 | (goto-char start) | 8810 | (goto-char start) |
| 8267 | nil) | 8811 | nil))))) |
| 8268 | ;;(gnus-summary-position-point) | ||
| 8269 | )))) | ||
| 8270 | 8812 | ||
| 8271 | (defun gnus-summary-go-to-next-thread (&optional previous) | 8813 | (defun gnus-summary-go-to-next-thread (&optional previous) |
| 8272 | "Go to the same level (or less) next thread. | 8814 | "Go to the same level (or less) next thread. |
| @@ -8398,14 +8940,14 @@ Argument REVERSE means reverse order." | |||
| 8398 | 8940 | ||
| 8399 | (defun gnus-summary-sort-by-author (&optional reverse) | 8941 | (defun gnus-summary-sort-by-author (&optional reverse) |
| 8400 | "Sort the summary buffer by author name alphabetically. | 8942 | "Sort the summary buffer by author name alphabetically. |
| 8401 | If case-fold-search is non-nil, case of letters is ignored. | 8943 | If `case-fold-search' is non-nil, case of letters is ignored. |
| 8402 | Argument REVERSE means reverse order." | 8944 | Argument REVERSE means reverse order." |
| 8403 | (interactive "P") | 8945 | (interactive "P") |
| 8404 | (gnus-summary-sort 'author reverse)) | 8946 | (gnus-summary-sort 'author reverse)) |
| 8405 | 8947 | ||
| 8406 | (defun gnus-summary-sort-by-subject (&optional reverse) | 8948 | (defun gnus-summary-sort-by-subject (&optional reverse) |
| 8407 | "Sort the summary buffer by subject alphabetically. `Re:'s are ignored. | 8949 | "Sort the summary buffer by subject alphabetically. `Re:'s are ignored. |
| 8408 | If case-fold-search is non-nil, case of letters is ignored. | 8950 | If `case-fold-search' is non-nil, case of letters is ignored. |
| 8409 | Argument REVERSE means reverse order." | 8951 | Argument REVERSE means reverse order." |
| 8410 | (interactive "P") | 8952 | (interactive "P") |
| 8411 | (gnus-summary-sort 'subject reverse)) | 8953 | (gnus-summary-sort 'subject reverse)) |
| @@ -8423,27 +8965,33 @@ Argument REVERSE means reverse order." | |||
| 8423 | (gnus-summary-sort 'score reverse)) | 8965 | (gnus-summary-sort 'score reverse)) |
| 8424 | 8966 | ||
| 8425 | (defun gnus-summary-sort-by-lines (&optional reverse) | 8967 | (defun gnus-summary-sort-by-lines (&optional reverse) |
| 8426 | "Sort the summary buffer by article length. | 8968 | "Sort the summary buffer by the number of lines. |
| 8427 | Argument REVERSE means reverse order." | 8969 | Argument REVERSE means reverse order." |
| 8428 | (interactive "P") | 8970 | (interactive "P") |
| 8429 | (gnus-summary-sort 'lines reverse)) | 8971 | (gnus-summary-sort 'lines reverse)) |
| 8430 | 8972 | ||
| 8973 | (defun gnus-summary-sort-by-chars (&optional reverse) | ||
| 8974 | "Sort the summary buffer by article length. | ||
| 8975 | Argument REVERSE means reverse order." | ||
| 8976 | (interactive "P") | ||
| 8977 | (gnus-summary-sort 'chars reverse)) | ||
| 8978 | |||
| 8431 | (defun gnus-summary-sort (predicate reverse) | 8979 | (defun gnus-summary-sort (predicate reverse) |
| 8432 | "Sort summary buffer by PREDICATE. REVERSE means reverse order." | 8980 | "Sort summary buffer by PREDICATE. REVERSE means reverse order." |
| 8433 | (let* ((thread (intern (format "gnus-thread-sort-by-%s" predicate))) | 8981 | (let* ((thread (intern (format "gnus-thread-sort-by-%s" predicate))) |
| 8434 | (article (intern (format "gnus-article-sort-by-%s" predicate))) | 8982 | (article (intern (format "gnus-article-sort-by-%s" predicate))) |
| 8435 | (gnus-thread-sort-functions | 8983 | (gnus-thread-sort-functions |
| 8436 | (list | 8984 | (if (not reverse) |
| 8437 | (if (not reverse) | 8985 | thread |
| 8438 | thread | 8986 | `(lambda (t1 t2) |
| 8439 | `(lambda (t1 t2) | 8987 | (,thread t2 t1)))) |
| 8440 | (,thread t2 t1))))) | 8988 | (gnus-sort-gathered-threads-function |
| 8989 | gnus-thread-sort-functions) | ||
| 8441 | (gnus-article-sort-functions | 8990 | (gnus-article-sort-functions |
| 8442 | (list | 8991 | (if (not reverse) |
| 8443 | (if (not reverse) | 8992 | article |
| 8444 | article | 8993 | `(lambda (t1 t2) |
| 8445 | `(lambda (t1 t2) | 8994 | (,article t2 t1)))) |
| 8446 | (,article t2 t1))))) | ||
| 8447 | (buffer-read-only) | 8995 | (buffer-read-only) |
| 8448 | (gnus-summary-prepare-hook nil)) | 8996 | (gnus-summary-prepare-hook nil)) |
| 8449 | ;; We do the sorting by regenerating the threads. | 8997 | ;; We do the sorting by regenerating the threads. |
| @@ -8466,10 +9014,9 @@ The variable `gnus-default-article-saver' specifies the saver function." | |||
| 8466 | (save-buffer (save-excursion | 9014 | (save-buffer (save-excursion |
| 8467 | (nnheader-set-temp-buffer " *Gnus Save*"))) | 9015 | (nnheader-set-temp-buffer " *Gnus Save*"))) |
| 8468 | (num (length articles)) | 9016 | (num (length articles)) |
| 8469 | header article file) | 9017 | header file) |
| 8470 | (while articles | 9018 | (dolist (article articles) |
| 8471 | (setq header (gnus-summary-article-header | 9019 | (setq header (gnus-summary-article-header article)) |
| 8472 | (setq article (pop articles)))) | ||
| 8473 | (if (not (vectorp header)) | 9020 | (if (not (vectorp header)) |
| 8474 | ;; This is a pseudo-article. | 9021 | ;; This is a pseudo-article. |
| 8475 | (if (assq 'name header) | 9022 | (if (assq 'name header) |
| @@ -8599,16 +9146,14 @@ save those articles instead." | |||
| 8599 | split-name)) | 9146 | split-name)) |
| 8600 | ((consp result) | 9147 | ((consp result) |
| 8601 | (setq split-name (append result split-name))))))))) | 9148 | (setq split-name (append result split-name))))))))) |
| 8602 | split-name)) | 9149 | (nreverse split-name))) |
| 8603 | 9150 | ||
| 8604 | (defun gnus-valid-move-group-p (group) | 9151 | (defun gnus-valid-move-group-p (group) |
| 8605 | (and (boundp group) | 9152 | (and (boundp group) |
| 8606 | (symbol-name group) | 9153 | (symbol-name group) |
| 8607 | (memq 'respool | 9154 | (symbol-value group) |
| 8608 | (assoc (symbol-name | 9155 | (gnus-get-function (gnus-find-method-for-group |
| 8609 | (car (gnus-find-method-for-group | 9156 | (symbol-name group)) 'request-accept-article t))) |
| 8610 | (symbol-name group)))) | ||
| 8611 | gnus-valid-select-methods)))) | ||
| 8612 | 9157 | ||
| 8613 | (defun gnus-read-move-group-name (prompt default articles prefix) | 9158 | (defun gnus-read-move-group-name (prompt default articles prefix) |
| 8614 | "Read a group name." | 9159 | "Read a group name." |
| @@ -8639,7 +9184,8 @@ save those articles instead." | |||
| 8639 | (mapcar (lambda (el) (list el)) | 9184 | (mapcar (lambda (el) (list el)) |
| 8640 | (nreverse split-name)) | 9185 | (nreverse split-name)) |
| 8641 | nil nil nil | 9186 | nil nil nil |
| 8642 | 'gnus-group-history))))) | 9187 | 'gnus-group-history)))) |
| 9188 | (to-method (gnus-server-to-method (gnus-group-method to-newsgroup)))) | ||
| 8643 | (when to-newsgroup | 9189 | (when to-newsgroup |
| 8644 | (if (or (string= to-newsgroup "") | 9190 | (if (or (string= to-newsgroup "") |
| 8645 | (string= to-newsgroup prefix)) | 9191 | (string= to-newsgroup prefix)) |
| @@ -8647,18 +9193,62 @@ save those articles instead." | |||
| 8647 | (unless to-newsgroup | 9193 | (unless to-newsgroup |
| 8648 | (error "No group name entered")) | 9194 | (error "No group name entered")) |
| 8649 | (or (gnus-active to-newsgroup) | 9195 | (or (gnus-active to-newsgroup) |
| 8650 | (gnus-activate-group to-newsgroup) | 9196 | (gnus-activate-group to-newsgroup nil nil to-method) |
| 8651 | (if (gnus-y-or-n-p (format "No such group: %s. Create it? " | 9197 | (if (gnus-y-or-n-p (format "No such group: %s. Create it? " |
| 8652 | to-newsgroup)) | 9198 | to-newsgroup)) |
| 8653 | (or (and (gnus-request-create-group | 9199 | (or (and (gnus-request-create-group to-newsgroup to-method) |
| 8654 | to-newsgroup (gnus-group-name-to-method to-newsgroup)) | 9200 | (gnus-activate-group |
| 8655 | (gnus-activate-group to-newsgroup nil nil | 9201 | to-newsgroup nil nil to-method) |
| 8656 | (gnus-group-name-to-method | 9202 | (gnus-subscribe-group to-newsgroup)) |
| 8657 | to-newsgroup))) | ||
| 8658 | (error "Couldn't create group %s" to-newsgroup))) | 9203 | (error "Couldn't create group %s" to-newsgroup))) |
| 8659 | (error "No such group: %s" to-newsgroup))) | 9204 | (error "No such group: %s" to-newsgroup))) |
| 8660 | to-newsgroup)) | 9205 | to-newsgroup)) |
| 8661 | 9206 | ||
| 9207 | (defun gnus-summary-save-parts (type dir n &optional reverse) | ||
| 9208 | "Save parts matching TYPE to DIR. | ||
| 9209 | If REVERSE, save parts that do not match TYPE." | ||
| 9210 | (interactive | ||
| 9211 | (list (read-string "Save parts of type: " | ||
| 9212 | (or (car gnus-summary-save-parts-type-history) | ||
| 9213 | gnus-summary-save-parts-default-mime) | ||
| 9214 | 'gnus-summary-save-parts-type-history) | ||
| 9215 | (setq gnus-summary-save-parts-last-directory | ||
| 9216 | (read-file-name "Save to directory: " | ||
| 9217 | gnus-summary-save-parts-last-directory | ||
| 9218 | nil t)) | ||
| 9219 | current-prefix-arg)) | ||
| 9220 | (gnus-summary-iterate n | ||
| 9221 | (let ((gnus-display-mime-function nil) | ||
| 9222 | (gnus-inhibit-treatment t)) | ||
| 9223 | (gnus-summary-select-article)) | ||
| 9224 | (save-excursion | ||
| 9225 | (set-buffer gnus-article-buffer) | ||
| 9226 | (let ((handles (or gnus-article-mime-handles | ||
| 9227 | (mm-dissect-buffer) (mm-uu-dissect)))) | ||
| 9228 | (when handles | ||
| 9229 | (gnus-summary-save-parts-1 type dir handles reverse) | ||
| 9230 | (unless gnus-article-mime-handles ;; Don't destroy this case. | ||
| 9231 | (mm-destroy-parts handles))))))) | ||
| 9232 | |||
| 9233 | (defun gnus-summary-save-parts-1 (type dir handle reverse) | ||
| 9234 | (if (stringp (car handle)) | ||
| 9235 | (mapcar (lambda (h) (gnus-summary-save-parts-1 type dir h reverse)) | ||
| 9236 | (cdr handle)) | ||
| 9237 | (when (if reverse | ||
| 9238 | (not (string-match type (mm-handle-media-type handle))) | ||
| 9239 | (string-match type (mm-handle-media-type handle))) | ||
| 9240 | (let ((file (expand-file-name | ||
| 9241 | (file-name-nondirectory | ||
| 9242 | (or | ||
| 9243 | (mail-content-type-get | ||
| 9244 | (mm-handle-disposition handle) 'filename) | ||
| 9245 | (concat gnus-newsgroup-name | ||
| 9246 | "." (number-to-string | ||
| 9247 | (cdr gnus-article-current))))) | ||
| 9248 | dir))) | ||
| 9249 | (unless (file-exists-p file) | ||
| 9250 | (mm-save-part-to-file handle file)))))) | ||
| 9251 | |||
| 8662 | ;; Summary extract commands | 9252 | ;; Summary extract commands |
| 8663 | 9253 | ||
| 8664 | (defun gnus-summary-insert-pseudos (pslist &optional not-view) | 9254 | (defun gnus-summary-insert-pseudos (pslist &optional not-view) |
| @@ -8694,7 +9284,7 @@ save those articles instead." | |||
| 8694 | (lambda (f) | 9284 | (lambda (f) |
| 8695 | (if (equal f " ") | 9285 | (if (equal f " ") |
| 8696 | f | 9286 | f |
| 8697 | (gnus-quote-arg-for-sh-or-csh f))) | 9287 | (mm-quote-arg f))) |
| 8698 | files " "))))) | 9288 | files " "))))) |
| 8699 | (setq ps (cdr ps))))) | 9289 | (setq ps (cdr ps))))) |
| 8700 | (if (and gnus-view-pseudos (not not-view)) | 9290 | (if (and gnus-view-pseudos (not not-view)) |
| @@ -8771,8 +9361,10 @@ save those articles instead." | |||
| 8771 | "Read the headers of article ID and enter them into the Gnus system." | 9361 | "Read the headers of article ID and enter them into the Gnus system." |
| 8772 | (let ((group gnus-newsgroup-name) | 9362 | (let ((group gnus-newsgroup-name) |
| 8773 | (gnus-override-method | 9363 | (gnus-override-method |
| 8774 | (and (gnus-news-group-p gnus-newsgroup-name) | 9364 | (or |
| 8775 | gnus-refer-article-method)) | 9365 | gnus-override-method |
| 9366 | (and (gnus-news-group-p gnus-newsgroup-name) | ||
| 9367 | (car (gnus-refer-article-methods))))) | ||
| 8776 | where) | 9368 | where) |
| 8777 | ;; First we check to see whether the header in question is already | 9369 | ;; First we check to see whether the header in question is already |
| 8778 | ;; fetched. | 9370 | ;; fetched. |
| @@ -8846,8 +9438,8 @@ save those articles instead." | |||
| 8846 | ;;; | 9438 | ;;; |
| 8847 | 9439 | ||
| 8848 | (defun gnus-highlight-selected-summary () | 9440 | (defun gnus-highlight-selected-summary () |
| 9441 | "Highlight selected article in summary buffer." | ||
| 8849 | ;; Added by Per Abrahamsen <amanda@iesd.auc.dk>. | 9442 | ;; Added by Per Abrahamsen <amanda@iesd.auc.dk>. |
| 8850 | ;; Highlight selected article in summary buffer | ||
| 8851 | (when gnus-summary-selected-face | 9443 | (when gnus-summary-selected-face |
| 8852 | (save-excursion | 9444 | (save-excursion |
| 8853 | (let* ((beg (progn (beginning-of-line) (point))) | 9445 | (let* ((beg (progn (beginning-of-line) (point))) |
| @@ -8938,19 +9530,38 @@ save those articles instead." | |||
| 8938 | (setq unread (cdr unread))) | 9530 | (setq unread (cdr unread))) |
| 8939 | (when (<= prev (cdr active)) | 9531 | (when (<= prev (cdr active)) |
| 8940 | (push (cons prev (cdr active)) read)) | 9532 | (push (cons prev (cdr active)) read)) |
| 9533 | (setq read (if (> (length read) 1) (nreverse read) read)) | ||
| 8941 | (if compute | 9534 | (if compute |
| 8942 | (if (> (length read) 1) (nreverse read) read) | 9535 | read |
| 8943 | (save-excursion | 9536 | (save-excursion |
| 8944 | (set-buffer gnus-group-buffer) | 9537 | (let (setmarkundo) |
| 8945 | (gnus-undo-register | 9538 | ;; Propagate the read marks to the backend. |
| 8946 | `(progn | 9539 | (when (gnus-check-backend-function 'request-set-mark group) |
| 8947 | (gnus-info-set-marks ',info ',(gnus-info-marks info) t) | 9540 | (let ((del (gnus-remove-from-range (gnus-info-read info) read)) |
| 8948 | (gnus-info-set-read ',info ',(gnus-info-read info)) | 9541 | (add (gnus-remove-from-range read (gnus-info-read info)))) |
| 8949 | (gnus-get-unread-articles-in-group ',info (gnus-active ,group)) | 9542 | (when (or add del) |
| 8950 | (gnus-group-update-group ,group t)))) | 9543 | (unless (gnus-check-group group) |
| 9544 | (error "Can't open server for %s" group)) | ||
| 9545 | (gnus-request-set-mark | ||
| 9546 | group (delq nil (list (if add (list add 'add '(read))) | ||
| 9547 | (if del (list del 'del '(read)))))) | ||
| 9548 | (setq setmarkundo | ||
| 9549 | `(gnus-request-set-mark | ||
| 9550 | ,group | ||
| 9551 | ',(delq nil (list | ||
| 9552 | (if del (list del 'add '(read))) | ||
| 9553 | (if add (list add 'del '(read)))))))))) | ||
| 9554 | (set-buffer gnus-group-buffer) | ||
| 9555 | (gnus-undo-register | ||
| 9556 | `(progn | ||
| 9557 | (gnus-info-set-marks ',info ',(gnus-info-marks info) t) | ||
| 9558 | (gnus-info-set-read ',info ',(gnus-info-read info)) | ||
| 9559 | (gnus-get-unread-articles-in-group ',info | ||
| 9560 | (gnus-active ,group)) | ||
| 9561 | (gnus-group-update-group ,group t) | ||
| 9562 | ,setmarkundo)))) | ||
| 8951 | ;; Enter this list into the group info. | 9563 | ;; Enter this list into the group info. |
| 8952 | (gnus-info-set-read | 9564 | (gnus-info-set-read info read) |
| 8953 | info (if (> (length read) 1) (nreverse read) read)) | ||
| 8954 | ;; Set the number of unread articles in gnus-newsrc-hashtb. | 9565 | ;; Set the number of unread articles in gnus-newsrc-hashtb. |
| 8955 | (gnus-get-unread-articles-in-group info (gnus-active group)) | 9566 | (gnus-get-unread-articles-in-group info (gnus-active group)) |
| 8956 | t)))) | 9567 | t)))) |
| @@ -8983,6 +9594,165 @@ save those articles instead." | |||
| 8983 | (gnus-summary-exit)) | 9594 | (gnus-summary-exit)) |
| 8984 | buffers))))) | 9595 | buffers))))) |
| 8985 | 9596 | ||
| 9597 | (defun gnus-summary-setup-default-charset () | ||
| 9598 | "Setup newsgroup default charset." | ||
| 9599 | (if (equal gnus-newsgroup-name "nndraft:drafts") | ||
| 9600 | (setq gnus-newsgroup-charset nil) | ||
| 9601 | (let* ((name (and gnus-newsgroup-name | ||
| 9602 | (gnus-group-real-name gnus-newsgroup-name))) | ||
| 9603 | (ignored-charsets | ||
| 9604 | (or gnus-newsgroup-ephemeral-ignored-charsets | ||
| 9605 | (append | ||
| 9606 | (and gnus-newsgroup-name | ||
| 9607 | (or (gnus-group-find-parameter gnus-newsgroup-name | ||
| 9608 | 'ignored-charsets t) | ||
| 9609 | (let ((alist gnus-group-ignored-charsets-alist) | ||
| 9610 | elem (charsets nil)) | ||
| 9611 | (while (setq elem (pop alist)) | ||
| 9612 | (when (and name | ||
| 9613 | (string-match (car elem) name)) | ||
| 9614 | (setq alist nil | ||
| 9615 | charsets (cdr elem)))) | ||
| 9616 | charsets))) | ||
| 9617 | gnus-newsgroup-ignored-charsets)))) | ||
| 9618 | (setq gnus-newsgroup-charset | ||
| 9619 | (or gnus-newsgroup-ephemeral-charset | ||
| 9620 | (and gnus-newsgroup-name | ||
| 9621 | (or (gnus-group-find-parameter gnus-newsgroup-name 'charset) | ||
| 9622 | (let ((alist gnus-group-charset-alist) | ||
| 9623 | elem charset) | ||
| 9624 | (while (setq elem (pop alist)) | ||
| 9625 | (when (and name | ||
| 9626 | (string-match (car elem) name)) | ||
| 9627 | (setq alist nil | ||
| 9628 | charset (cadr elem)))) | ||
| 9629 | charset))) | ||
| 9630 | gnus-default-charset)) | ||
| 9631 | (set (make-local-variable 'gnus-newsgroup-ignored-charsets) | ||
| 9632 | ignored-charsets)))) | ||
| 9633 | |||
| 9634 | ;;; | ||
| 9635 | ;;; Mime Commands | ||
| 9636 | ;;; | ||
| 9637 | |||
| 9638 | (defun gnus-summary-display-buttonized (&optional show-all-parts) | ||
| 9639 | "Display the current article buffer fully MIME-buttonized. | ||
| 9640 | If SHOW-ALL-PARTS (the prefix) is non-nil, all multipart/* parts are | ||
| 9641 | treated as multipart/mixed." | ||
| 9642 | (interactive "P") | ||
| 9643 | (require 'gnus-art) | ||
| 9644 | (let ((gnus-unbuttonized-mime-types nil) | ||
| 9645 | (gnus-mime-display-multipart-as-mixed show-all-parts)) | ||
| 9646 | (gnus-summary-show-article))) | ||
| 9647 | |||
| 9648 | (defun gnus-summary-repair-multipart (article) | ||
| 9649 | "Add a Content-Type header to a multipart article without one." | ||
| 9650 | (interactive (list (gnus-summary-article-number))) | ||
| 9651 | (gnus-with-article article | ||
| 9652 | (message-narrow-to-head) | ||
| 9653 | (goto-char (point-max)) | ||
| 9654 | (widen) | ||
| 9655 | (when (search-forward "\n--" nil t) | ||
| 9656 | (let ((separator (buffer-substring (point) (gnus-point-at-eol)))) | ||
| 9657 | (message-narrow-to-head) | ||
| 9658 | (message-remove-header "Mime-Version") | ||
| 9659 | (message-remove-header "Content-Type") | ||
| 9660 | (goto-char (point-max)) | ||
| 9661 | (insert (format "Content-Type: multipart/mixed; boundary=\"%s\"\n" | ||
| 9662 | separator)) | ||
| 9663 | (insert "Mime-Version: 1.0\n") | ||
| 9664 | (widen)))) | ||
| 9665 | (let (gnus-mark-article-hook) | ||
| 9666 | (gnus-summary-select-article t t nil article))) | ||
| 9667 | |||
| 9668 | (defun gnus-summary-toggle-display-buttonized () | ||
| 9669 | "Toggle the buttonizing of the article buffer." | ||
| 9670 | (interactive) | ||
| 9671 | (require 'gnus-art) | ||
| 9672 | (if (setq gnus-inhibit-mime-unbuttonizing | ||
| 9673 | (not gnus-inhibit-mime-unbuttonizing)) | ||
| 9674 | (let ((gnus-unbuttonized-mime-types nil)) | ||
| 9675 | (gnus-summary-show-article)) | ||
| 9676 | (gnus-summary-show-article))) | ||
| 9677 | |||
| 9678 | ;;; | ||
| 9679 | ;;; Generic summary marking commands | ||
| 9680 | ;;; | ||
| 9681 | |||
| 9682 | (defvar gnus-summary-marking-alist | ||
| 9683 | '((read gnus-del-mark "d") | ||
| 9684 | (unread gnus-unread-mark "u") | ||
| 9685 | (ticked gnus-ticked-mark "!") | ||
| 9686 | (dormant gnus-dormant-mark "?") | ||
| 9687 | (expirable gnus-expirable-mark "e")) | ||
| 9688 | "An alist of names/marks/keystrokes.") | ||
| 9689 | |||
| 9690 | (defvar gnus-summary-generic-mark-map (make-sparse-keymap)) | ||
| 9691 | (defvar gnus-summary-mark-map) | ||
| 9692 | |||
| 9693 | (defun gnus-summary-make-all-marking-commands () | ||
| 9694 | (define-key gnus-summary-mark-map "M" gnus-summary-generic-mark-map) | ||
| 9695 | (dolist (elem gnus-summary-marking-alist) | ||
| 9696 | (apply 'gnus-summary-make-marking-command elem))) | ||
| 9697 | |||
| 9698 | (defun gnus-summary-make-marking-command (name mark keystroke) | ||
| 9699 | (let ((map (make-sparse-keymap))) | ||
| 9700 | (define-key gnus-summary-generic-mark-map keystroke map) | ||
| 9701 | (dolist (lway `((next "next" next nil "n") | ||
| 9702 | (next-unread "next unread" next t "N") | ||
| 9703 | (prev "previous" prev nil "p") | ||
| 9704 | (prev-unread "previous unread" prev t "P") | ||
| 9705 | (nomove "" nil nil ,keystroke))) | ||
| 9706 | (let ((func (gnus-summary-make-marking-command-1 | ||
| 9707 | mark (car lway) lway name))) | ||
| 9708 | (setq func (eval func)) | ||
| 9709 | (define-key map (nth 4 lway) func))))) | ||
| 9710 | |||
| 9711 | (defun gnus-summary-make-marking-command-1 (mark way lway name) | ||
| 9712 | `(defun ,(intern | ||
| 9713 | (format "gnus-summary-put-mark-as-%s%s" | ||
| 9714 | name (if (eq way 'nomove) | ||
| 9715 | "" | ||
| 9716 | (concat "-" (symbol-name way))))) | ||
| 9717 | (n) | ||
| 9718 | ,(format | ||
| 9719 | "Mark the current article as %s%s. | ||
| 9720 | If N, the prefix, then repeat N times. | ||
| 9721 | If N is negative, move in reverse order. | ||
| 9722 | The difference between N and the actual number of articles marked is | ||
| 9723 | returned." | ||
| 9724 | name (cadr lway)) | ||
| 9725 | (interactive "p") | ||
| 9726 | (gnus-summary-generic-mark n ,mark ',(nth 2 lway) ,(nth 3 lway)))) | ||
| 9727 | |||
| 9728 | (defun gnus-summary-generic-mark (n mark move unread) | ||
| 9729 | "Mark N articles with MARK." | ||
| 9730 | (unless (eq major-mode 'gnus-summary-mode) | ||
| 9731 | (error "This command can only be used in the summary buffer")) | ||
| 9732 | (gnus-summary-show-thread) | ||
| 9733 | (let ((nummove | ||
| 9734 | (cond | ||
| 9735 | ((eq move 'next) 1) | ||
| 9736 | ((eq move 'prev) -1) | ||
| 9737 | (t 0)))) | ||
| 9738 | (if (zerop nummove) | ||
| 9739 | (setq n 1) | ||
| 9740 | (when (< n 0) | ||
| 9741 | (setq n (abs n) | ||
| 9742 | nummove (* -1 nummove)))) | ||
| 9743 | (while (and (> n 0) | ||
| 9744 | (gnus-summary-mark-article nil mark) | ||
| 9745 | (zerop (gnus-summary-next-subject nummove unread t))) | ||
| 9746 | (setq n (1- n))) | ||
| 9747 | (when (/= 0 n) | ||
| 9748 | (gnus-message 7 "No more %sarticles" (if mark "" "unread "))) | ||
| 9749 | (gnus-summary-recenter) | ||
| 9750 | (gnus-summary-position-point) | ||
| 9751 | (gnus-set-mode-line 'summary) | ||
| 9752 | n)) | ||
| 9753 | |||
| 9754 | (gnus-summary-make-all-marking-commands) | ||
| 9755 | |||
| 8986 | (gnus-ems-redefine) | 9756 | (gnus-ems-redefine) |
| 8987 | 9757 | ||
| 8988 | (provide 'gnus-sum) | 9758 | (provide 'gnus-sum) |
diff --git a/lisp/gnus/gnus-topic.el b/lisp/gnus/gnus-topic.el index 26b91f8072f..35324395bb7 100644 --- a/lisp/gnus/gnus-topic.el +++ b/lisp/gnus/gnus-topic.el | |||
| @@ -1,5 +1,6 @@ | |||
| 1 | ;;; gnus-topic.el --- a folding minor mode for Gnus group buffers | 1 | ;;; gnus-topic.el --- a folding minor mode for Gnus group buffers |
| 2 | ;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. | 2 | ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 |
| 3 | ;; Free Software Foundation, Inc. | ||
| 3 | 4 | ||
| 4 | ;; Author: Ilja Weis <kult@uni-paderborn.de> | 5 | ;; Author: Ilja Weis <kult@uni-paderborn.de> |
| 5 | ;; Lars Magne Ingebrigtsen <larsi@gnus.org> | 6 | ;; Lars Magne Ingebrigtsen <larsi@gnus.org> |
| @@ -28,8 +29,6 @@ | |||
| 28 | 29 | ||
| 29 | (eval-when-compile (require 'cl)) | 30 | (eval-when-compile (require 'cl)) |
| 30 | 31 | ||
| 31 | (eval-when-compile (require 'cl)) | ||
| 32 | |||
| 33 | (require 'gnus) | 32 | (require 'gnus) |
| 34 | (require 'gnus-group) | 33 | (require 'gnus-group) |
| 35 | (require 'gnus-start) | 34 | (require 'gnus-start) |
| @@ -151,11 +150,20 @@ with some simple extensions. | |||
| 151 | (gnus-group-topic group)))) | 150 | (gnus-group-topic group)))) |
| 152 | 151 | ||
| 153 | (defun gnus-topic-goto-topic (topic) | 152 | (defun gnus-topic-goto-topic (topic) |
| 154 | "Go to TOPIC." | ||
| 155 | (when topic | 153 | (when topic |
| 156 | (gnus-goto-char (text-property-any (point-min) (point-max) | 154 | (gnus-goto-char (text-property-any (point-min) (point-max) |
| 157 | 'gnus-topic (intern topic))))) | 155 | 'gnus-topic (intern topic))))) |
| 158 | 156 | ||
| 157 | (defun gnus-topic-jump-to-topic (topic) | ||
| 158 | "Go to TOPIC." | ||
| 159 | (interactive | ||
| 160 | (list (completing-read "Go to topic: " | ||
| 161 | (mapcar 'list (gnus-topic-list)) | ||
| 162 | nil t))) | ||
| 163 | (dolist (topic (gnus-current-topics topic)) | ||
| 164 | (gnus-topic-fold t)) | ||
| 165 | (gnus-topic-goto-topic topic)) | ||
| 166 | |||
| 159 | (defun gnus-current-topic () | 167 | (defun gnus-current-topic () |
| 160 | "Return the name of the current topic." | 168 | "Return the name of the current topic." |
| 161 | (let ((result | 169 | (let ((result |
| @@ -184,8 +192,9 @@ If TOPIC, start with that topic." | |||
| 184 | (beginning-of-line) | 192 | (beginning-of-line) |
| 185 | (get-text-property (point) 'gnus-active))) | 193 | (get-text-property (point) 'gnus-active))) |
| 186 | 194 | ||
| 187 | (defun gnus-topic-find-groups (topic &optional level all lowest) | 195 | (defun gnus-topic-find-groups (topic &optional level all lowest recursive) |
| 188 | "Return entries for all visible groups in TOPIC." | 196 | "Return entries for all visible groups in TOPIC. |
| 197 | If RECURSIVE is t, return groups in its subtopics too." | ||
| 189 | (let ((groups (cdr (assoc topic gnus-topic-alist))) | 198 | (let ((groups (cdr (assoc topic gnus-topic-alist))) |
| 190 | info clevel unread group params visible-groups entry active) | 199 | info clevel unread group params visible-groups entry active) |
| 191 | (setq lowest (or lowest 1)) | 200 | (setq lowest (or lowest 1)) |
| @@ -205,16 +214,17 @@ If TOPIC, start with that topic." | |||
| 205 | (if (member group gnus-zombie-list) | 214 | (if (member group gnus-zombie-list) |
| 206 | gnus-level-zombie gnus-level-killed)))) | 215 | gnus-level-zombie gnus-level-killed)))) |
| 207 | (and | 216 | (and |
| 208 | unread ; nil means that the group is dead. | 217 | info ; nil means that the group is dead. |
| 209 | (<= clevel level) | 218 | (<= clevel level) |
| 210 | (>= clevel lowest) ; Is inside the level we want. | 219 | (>= clevel lowest) ; Is inside the level we want. |
| 211 | (or all | 220 | (or all |
| 212 | (if (eq unread t) | 221 | (if (or (eq unread t) |
| 222 | (eq unread nil)) | ||
| 213 | gnus-group-list-inactive-groups | 223 | gnus-group-list-inactive-groups |
| 214 | (> unread 0)) | 224 | (> unread 0)) |
| 215 | (and gnus-list-groups-with-ticked-articles | 225 | (and gnus-list-groups-with-ticked-articles |
| 216 | (cdr (assq 'tick (gnus-info-marks info)))) | 226 | (cdr (assq 'tick (gnus-info-marks info)))) |
| 217 | ; Has right readedness. | 227 | ;; Has right readedness. |
| 218 | ;; Check for permanent visibility. | 228 | ;; Check for permanent visibility. |
| 219 | (and gnus-permanently-visible-groups | 229 | (and gnus-permanently-visible-groups |
| 220 | (string-match gnus-permanently-visible-groups group)) | 230 | (string-match gnus-permanently-visible-groups group)) |
| @@ -222,7 +232,18 @@ If TOPIC, start with that topic." | |||
| 222 | (cdr (assq 'visible params))) | 232 | (cdr (assq 'visible params))) |
| 223 | ;; Add this group to the list of visible groups. | 233 | ;; Add this group to the list of visible groups. |
| 224 | (push (or entry group) visible-groups))) | 234 | (push (or entry group) visible-groups))) |
| 225 | (nreverse visible-groups))) | 235 | (setq visible-groups (nreverse visible-groups)) |
| 236 | (when recursive | ||
| 237 | (if (eq recursive t) | ||
| 238 | (setq recursive (cdr (gnus-topic-find-topology topic)))) | ||
| 239 | (mapcar (lambda (topic-topology) | ||
| 240 | (setq visible-groups | ||
| 241 | (nconc visible-groups | ||
| 242 | (gnus-topic-find-groups | ||
| 243 | (caar topic-topology) | ||
| 244 | level all lowest topic-topology)))) | ||
| 245 | (cdr recursive))) | ||
| 246 | visible-groups)) | ||
| 226 | 247 | ||
| 227 | (defun gnus-topic-previous-topic (topic) | 248 | (defun gnus-topic-previous-topic (topic) |
| 228 | "Return the previous topic on the same level as TOPIC." | 249 | "Return the previous topic on the same level as TOPIC." |
| @@ -363,7 +384,8 @@ If TOPIC, start with that topic." | |||
| 363 | 384 | ||
| 364 | ;;; Generating group buffers | 385 | ;;; Generating group buffers |
| 365 | 386 | ||
| 366 | (defun gnus-group-prepare-topics (level &optional all lowest regexp list-topic topic-level) | 387 | (defun gnus-group-prepare-topics (level &optional all lowest |
| 388 | regexp list-topic topic-level) | ||
| 367 | "List all newsgroups with unread articles of level LEVEL or lower. | 389 | "List all newsgroups with unread articles of level LEVEL or lower. |
| 368 | Use the `gnus-group-topics' to sort the groups. | 390 | Use the `gnus-group-topics' to sort the groups. |
| 369 | If ALL is non-nil, list groups that have no unread articles. | 391 | If ALL is non-nil, list groups that have no unread articles. |
| @@ -418,7 +440,7 @@ articles in the topic and its subtopics." | |||
| 418 | (entries (gnus-topic-find-groups | 440 | (entries (gnus-topic-find-groups |
| 419 | (car type) list-level | 441 | (car type) list-level |
| 420 | (or all | 442 | (or all |
| 421 | (cdr (assq 'visible | 443 | (cdr (assq 'visible |
| 422 | (gnus-topic-hierarchical-parameters | 444 | (gnus-topic-hierarchical-parameters |
| 423 | (car type))))) | 445 | (car type))))) |
| 424 | lowest)) | 446 | lowest)) |
| @@ -446,7 +468,8 @@ articles in the topic and its subtopics." | |||
| 446 | (if (stringp entry) | 468 | (if (stringp entry) |
| 447 | ;; Dead groups. | 469 | ;; Dead groups. |
| 448 | (gnus-group-insert-group-line | 470 | (gnus-group-insert-group-line |
| 449 | entry (if (member entry gnus-zombie-list) gnus-level-zombie gnus-level-killed) | 471 | entry (if (member entry gnus-zombie-list) |
| 472 | gnus-level-zombie gnus-level-killed) | ||
| 450 | nil (- (1+ (cdr (setq active (gnus-active entry)))) | 473 | nil (- (1+ (cdr (setq active (gnus-active entry)))) |
| 451 | (car active)) | 474 | (car active)) |
| 452 | nil) | 475 | nil) |
| @@ -494,7 +517,7 @@ articles in the topic and its subtopics." | |||
| 494 | (let ((data (cadr (gnus-topic-find-topology topic)))) | 517 | (let ((data (cadr (gnus-topic-find-topology topic)))) |
| 495 | (setcdr data | 518 | (setcdr data |
| 496 | (list (if insert 'visible 'invisible) | 519 | (list (if insert 'visible 'invisible) |
| 497 | (if hide 'hide nil) | 520 | (caddr data) |
| 498 | (cadddr data)))) | 521 | (cadddr data)))) |
| 499 | (if total-remove | 522 | (if total-remove |
| 500 | (setq gnus-topic-alist | 523 | (setq gnus-topic-alist |
| @@ -507,9 +530,9 @@ articles in the topic and its subtopics." | |||
| 507 | (car gnus-group-list-mode) (cdr gnus-group-list-mode) | 530 | (car gnus-group-list-mode) (cdr gnus-group-list-mode) |
| 508 | nil nil topic level)) | 531 | nil nil topic level)) |
| 509 | 532 | ||
| 510 | (defun gnus-topic-fold (&optional insert) | 533 | (defun gnus-topic-fold (&optional insert topic) |
| 511 | "Remove/insert the current topic." | 534 | "Remove/insert the current topic." |
| 512 | (let ((topic (gnus-group-topic-name))) | 535 | (let ((topic (or topic (gnus-group-topic-name)))) |
| 513 | (when topic | 536 | (when topic |
| 514 | (save-excursion | 537 | (save-excursion |
| 515 | (if (not (gnus-group-active-topic-p)) | 538 | (if (not (gnus-group-active-topic-p)) |
| @@ -533,15 +556,16 @@ articles in the topic and its subtopics." | |||
| 533 | (gnus-topic-update-unreads name unread) | 556 | (gnus-topic-update-unreads name unread) |
| 534 | (beginning-of-line) | 557 | (beginning-of-line) |
| 535 | ;; Insert the text. | 558 | ;; Insert the text. |
| 536 | (gnus-add-text-properties | 559 | (if shownp |
| 537 | (point) | 560 | (gnus-add-text-properties |
| 538 | (prog1 (1+ (point)) | 561 | (point) |
| 539 | (eval gnus-topic-line-format-spec)) | 562 | (prog1 (1+ (point)) |
| 540 | (list 'gnus-topic (intern name) | 563 | (eval gnus-topic-line-format-spec)) |
| 541 | 'gnus-topic-level level | 564 | (list 'gnus-topic (intern name) |
| 542 | 'gnus-topic-unread unread | 565 | 'gnus-topic-level level |
| 543 | 'gnus-active active-topic | 566 | 'gnus-topic-unread unread |
| 544 | 'gnus-topic-visible visiblep)))) | 567 | 'gnus-active active-topic |
| 568 | 'gnus-topic-visible visiblep))))) | ||
| 545 | 569 | ||
| 546 | (defun gnus-topic-update-unreads (topic unreads) | 570 | (defun gnus-topic-update-unreads (topic unreads) |
| 547 | (setq gnus-topic-unreads (delq (assoc topic gnus-topic-unreads) | 571 | (setq gnus-topic-unreads (delq (assoc topic gnus-topic-unreads) |
| @@ -584,7 +608,8 @@ articles in the topic and its subtopics." | |||
| 584 | (let* ((topic (gnus-group-topic group)) | 608 | (let* ((topic (gnus-group-topic group)) |
| 585 | (groups (cdr (assoc topic gnus-topic-alist))) | 609 | (groups (cdr (assoc topic gnus-topic-alist))) |
| 586 | (g (cdr (member group groups))) | 610 | (g (cdr (member group groups))) |
| 587 | (unfound t)) | 611 | (unfound t) |
| 612 | entry) | ||
| 588 | ;; Try to jump to a visible group. | 613 | ;; Try to jump to a visible group. |
| 589 | (while (and g (not (gnus-group-goto-group (car g) t))) | 614 | (while (and g (not (gnus-group-goto-group (car g) t))) |
| 590 | (pop g)) | 615 | (pop g)) |
| @@ -598,8 +623,20 @@ articles in the topic and its subtopics." | |||
| 598 | (when (and unfound | 623 | (when (and unfound |
| 599 | topic | 624 | topic |
| 600 | (not (gnus-topic-goto-missing-topic topic))) | 625 | (not (gnus-topic-goto-missing-topic topic))) |
| 601 | (gnus-topic-insert-topic-line | 626 | (let* ((top (gnus-topic-find-topology topic)) |
| 602 | topic t t (car (gnus-topic-find-topology topic)) nil 0))))) | 627 | (children (cddr top)) |
| 628 | (type (cadr top)) | ||
| 629 | (unread 0) | ||
| 630 | (entries (gnus-topic-find-groups | ||
| 631 | (car type) (car gnus-group-list-mode) | ||
| 632 | (cdr gnus-group-list-mode)))) | ||
| 633 | (while children | ||
| 634 | (incf unread (gnus-topic-unread (caar (pop children))))) | ||
| 635 | (while (setq entry (pop entries)) | ||
| 636 | (when (numberp (car entry)) | ||
| 637 | (incf unread (car entry)))) | ||
| 638 | (gnus-topic-insert-topic-line | ||
| 639 | topic t t (car (gnus-topic-find-topology topic)) nil unread)))))) | ||
| 603 | 640 | ||
| 604 | (defun gnus-topic-goto-missing-topic (topic) | 641 | (defun gnus-topic-goto-missing-topic (topic) |
| 605 | (if (gnus-topic-goto-topic topic) | 642 | (if (gnus-topic-goto-topic topic) |
| @@ -608,15 +645,18 @@ articles in the topic and its subtopics." | |||
| 608 | (let* ((top (gnus-topic-find-topology | 645 | (let* ((top (gnus-topic-find-topology |
| 609 | (gnus-topic-parent-topic topic))) | 646 | (gnus-topic-parent-topic topic))) |
| 610 | (tp (reverse (cddr top)))) | 647 | (tp (reverse (cddr top)))) |
| 611 | (while (not (equal (caaar tp) topic)) | 648 | (if (not top) |
| 612 | (setq tp (cdr tp))) | 649 | (gnus-topic-insert-topic-line |
| 613 | (pop tp) | 650 | topic t t (car (gnus-topic-find-topology topic)) nil 0) |
| 614 | (while (and tp | 651 | (while (not (equal (caaar tp) topic)) |
| 615 | (not (gnus-topic-goto-topic (caaar tp)))) | 652 | (setq tp (cdr tp))) |
| 616 | (pop tp)) | 653 | (pop tp) |
| 617 | (if tp | 654 | (while (and tp |
| 618 | (gnus-topic-forward-topic 1) | 655 | (not (gnus-topic-goto-topic (caaar tp)))) |
| 619 | (gnus-topic-goto-missing-topic (caadr top)))) | 656 | (pop tp)) |
| 657 | (if tp | ||
| 658 | (gnus-topic-forward-topic 1) | ||
| 659 | (gnus-topic-goto-missing-topic (caadr top))))) | ||
| 620 | nil)) | 660 | nil)) |
| 621 | 661 | ||
| 622 | (defun gnus-topic-update-topic-line (topic-name &optional reads) | 662 | (defun gnus-topic-update-topic-line (topic-name &optional reads) |
| @@ -908,6 +948,7 @@ articles in the topic and its subtopics." | |||
| 908 | "=" gnus-topic-select-group | 948 | "=" gnus-topic-select-group |
| 909 | "\r" gnus-topic-select-group | 949 | "\r" gnus-topic-select-group |
| 910 | " " gnus-topic-read-group | 950 | " " gnus-topic-read-group |
| 951 | "\C-c\C-x" gnus-topic-expire-articles | ||
| 911 | "\C-k" gnus-topic-kill-group | 952 | "\C-k" gnus-topic-kill-group |
| 912 | "\C-y" gnus-topic-yank-group | 953 | "\C-y" gnus-topic-yank-group |
| 913 | "\M-g" gnus-topic-get-new-news-this-topic | 954 | "\M-g" gnus-topic-get-new-news-this-topic |
| @@ -931,6 +972,7 @@ articles in the topic and its subtopics." | |||
| 931 | "c" gnus-topic-copy-group | 972 | "c" gnus-topic-copy-group |
| 932 | "h" gnus-topic-hide-topic | 973 | "h" gnus-topic-hide-topic |
| 933 | "s" gnus-topic-show-topic | 974 | "s" gnus-topic-show-topic |
| 975 | "j" gnus-topic-jump-to-topic | ||
| 934 | "M" gnus-topic-move-matching | 976 | "M" gnus-topic-move-matching |
| 935 | "C" gnus-topic-copy-matching | 977 | "C" gnus-topic-copy-matching |
| 936 | "\C-i" gnus-topic-indent | 978 | "\C-i" gnus-topic-indent |
| @@ -962,6 +1004,7 @@ articles in the topic and its subtopics." | |||
| 962 | ["Copy matching" gnus-topic-copy-matching t] | 1004 | ["Copy matching" gnus-topic-copy-matching t] |
| 963 | ["Move matching" gnus-topic-move-matching t]) | 1005 | ["Move matching" gnus-topic-move-matching t]) |
| 964 | ("Topics" | 1006 | ("Topics" |
| 1007 | ["Goto" gnus-topic-jump-to-topic t] | ||
| 965 | ["Show" gnus-topic-show-topic t] | 1008 | ["Show" gnus-topic-show-topic t] |
| 966 | ["Hide" gnus-topic-hide-topic t] | 1009 | ["Hide" gnus-topic-hide-topic t] |
| 967 | ["Delete" gnus-topic-delete t] | 1010 | ["Delete" gnus-topic-delete t] |
| @@ -969,6 +1012,7 @@ articles in the topic and its subtopics." | |||
| 969 | ["Create" gnus-topic-create-topic t] | 1012 | ["Create" gnus-topic-create-topic t] |
| 970 | ["Mark" gnus-topic-mark-topic t] | 1013 | ["Mark" gnus-topic-mark-topic t] |
| 971 | ["Indent" gnus-topic-indent t] | 1014 | ["Indent" gnus-topic-indent t] |
| 1015 | ["Sort" gnus-topic-sort-topics t] | ||
| 972 | ["Toggle hide empty" gnus-topic-toggle-display-empty-topics t] | 1016 | ["Toggle hide empty" gnus-topic-toggle-display-empty-topics t] |
| 973 | ["Edit parameters" gnus-topic-edit-parameters t]) | 1017 | ["Edit parameters" gnus-topic-edit-parameters t]) |
| 974 | ["List active" gnus-topic-list-active t])))) | 1018 | ["List active" gnus-topic-list-active t])))) |
| @@ -982,12 +1026,15 @@ articles in the topic and its subtopics." | |||
| 982 | (if (null arg) (not gnus-topic-mode) | 1026 | (if (null arg) (not gnus-topic-mode) |
| 983 | (> (prefix-numeric-value arg) 0))) | 1027 | (> (prefix-numeric-value arg) 0))) |
| 984 | ;; Infest Gnus with topics. | 1028 | ;; Infest Gnus with topics. |
| 985 | (if (not gnus-topic-mode) | 1029 | (if (not gnus-topic-mode) |
| 986 | (setq gnus-goto-missing-group-function nil) | 1030 | (setq gnus-goto-missing-group-function nil) |
| 987 | (when (gnus-visual-p 'topic-menu 'menu) | 1031 | (when (gnus-visual-p 'topic-menu 'menu) |
| 988 | (gnus-topic-make-menu-bar)) | 1032 | (gnus-topic-make-menu-bar)) |
| 989 | (gnus-set-format 'topic t) | 1033 | (gnus-set-format 'topic t) |
| 990 | (gnus-add-minor-mode 'gnus-topic-mode " Topic" gnus-topic-mode-map) | 1034 | (gnus-add-minor-mode 'gnus-topic-mode " Topic" |
| 1035 | gnus-topic-mode-map nil (lambda (&rest junk) | ||
| 1036 | (interactive) | ||
| 1037 | (gnus-topic-mode nil t))) | ||
| 991 | (add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic) | 1038 | (add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic) |
| 992 | (set (make-local-variable 'gnus-group-prepare-function) | 1039 | (set (make-local-variable 'gnus-group-prepare-function) |
| 993 | 'gnus-group-prepare-topics) | 1040 | 'gnus-group-prepare-topics) |
| @@ -1032,7 +1079,8 @@ If performed over a topic line, toggle folding the topic." | |||
| 1032 | (if (gnus-group-topic-p) | 1079 | (if (gnus-group-topic-p) |
| 1033 | (let ((gnus-group-list-mode | 1080 | (let ((gnus-group-list-mode |
| 1034 | (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode))) | 1081 | (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode))) |
| 1035 | (gnus-topic-fold all)) | 1082 | (gnus-topic-fold all) |
| 1083 | (gnus-dribble-touch)) | ||
| 1036 | (gnus-group-select-group all))) | 1084 | (gnus-group-select-group all))) |
| 1037 | 1085 | ||
| 1038 | (defun gnus-mouse-pick-topic (e) | 1086 | (defun gnus-mouse-pick-topic (e) |
| @@ -1041,6 +1089,19 @@ If performed over a topic line, toggle folding the topic." | |||
| 1041 | (mouse-set-point e) | 1089 | (mouse-set-point e) |
| 1042 | (gnus-topic-read-group nil)) | 1090 | (gnus-topic-read-group nil)) |
| 1043 | 1091 | ||
| 1092 | (defun gnus-topic-expire-articles (topic) | ||
| 1093 | "Expire articles in this topic or group." | ||
| 1094 | (interactive (list (gnus-group-topic-name))) | ||
| 1095 | (if (not topic) | ||
| 1096 | (call-interactively 'gnus-group-expire-articles) | ||
| 1097 | (save-excursion | ||
| 1098 | (gnus-message 5 "Expiring groups in %s..." topic) | ||
| 1099 | (let ((gnus-group-marked | ||
| 1100 | (mapcar (lambda (entry) (car (nth 2 entry))) | ||
| 1101 | (gnus-topic-find-groups topic gnus-level-killed t)))) | ||
| 1102 | (gnus-group-expire-articles nil)) | ||
| 1103 | (gnus-message 5 "Expiring groups in %s...done" topic)))) | ||
| 1104 | |||
| 1044 | (defun gnus-topic-read-group (&optional all no-article group) | 1105 | (defun gnus-topic-read-group (&optional all no-article group) |
| 1045 | "Read news in this newsgroup. | 1106 | "Read news in this newsgroup. |
| 1046 | If the prefix argument ALL is non-nil, already read articles become | 1107 | If the prefix argument ALL is non-nil, already read articles become |
| @@ -1086,44 +1147,60 @@ When used interactively, PARENT will be the topic under point." | |||
| 1086 | (gnus-group-list-groups) | 1147 | (gnus-group-list-groups) |
| 1087 | (gnus-topic-goto-topic topic)) | 1148 | (gnus-topic-goto-topic topic)) |
| 1088 | 1149 | ||
| 1150 | ;; FIXME: | ||
| 1151 | ;; 1. When the marked groups are overlapped with the process | ||
| 1152 | ;; region, the behavior of move or remove is not right. | ||
| 1153 | ;; 2. Can't process on several marked groups with a same name, | ||
| 1154 | ;; because gnus-group-marked only keeps one copy. | ||
| 1155 | |||
| 1089 | (defun gnus-topic-move-group (n topic &optional copyp) | 1156 | (defun gnus-topic-move-group (n topic &optional copyp) |
| 1090 | "Move the next N groups to TOPIC. | 1157 | "Move the next N groups to TOPIC. |
| 1091 | If COPYP, copy the groups instead." | 1158 | If COPYP, copy the groups instead." |
| 1092 | (interactive | 1159 | (interactive |
| 1093 | (list current-prefix-arg | 1160 | (list current-prefix-arg |
| 1094 | (completing-read "Move to topic: " gnus-topic-alist nil t))) | 1161 | (completing-read "Move to topic: " gnus-topic-alist nil t))) |
| 1095 | (let ((groups (gnus-group-process-prefix n)) | 1162 | (let ((use-marked (and (not n) (not (gnus-region-active-p)) |
| 1163 | gnus-group-marked t)) | ||
| 1164 | (groups (gnus-group-process-prefix n)) | ||
| 1096 | (topicl (assoc topic gnus-topic-alist)) | 1165 | (topicl (assoc topic gnus-topic-alist)) |
| 1097 | (start-group (progn (forward-line 1) (gnus-group-group-name))) | ||
| 1098 | (start-topic (gnus-group-topic-name)) | 1166 | (start-topic (gnus-group-topic-name)) |
| 1167 | (start-group (progn (forward-line 1) (gnus-group-group-name))) | ||
| 1099 | entry) | 1168 | entry) |
| 1100 | (mapcar | 1169 | (if (and (not groups) (not copyp) start-topic) |
| 1101 | (lambda (g) | 1170 | (gnus-topic-move start-topic topic) |
| 1102 | (gnus-group-remove-mark g) | 1171 | (mapcar |
| 1103 | (when (and | 1172 | (lambda (g) |
| 1104 | (setq entry (assoc (gnus-current-topic) gnus-topic-alist)) | 1173 | (gnus-group-remove-mark g use-marked) |
| 1105 | (not copyp)) | 1174 | (when (and |
| 1106 | (setcdr entry (gnus-delete-first g (cdr entry)))) | 1175 | (setq entry (assoc (gnus-current-topic) gnus-topic-alist)) |
| 1107 | (nconc topicl (list g))) | 1176 | (not copyp)) |
| 1108 | groups) | 1177 | (setcdr entry (gnus-delete-first g (cdr entry)))) |
| 1109 | (gnus-topic-enter-dribble) | 1178 | (nconc topicl (list g))) |
| 1110 | (if start-group | 1179 | groups) |
| 1111 | (gnus-group-goto-group start-group) | 1180 | (gnus-topic-enter-dribble) |
| 1112 | (gnus-topic-goto-topic start-topic)) | 1181 | (if start-group |
| 1113 | (gnus-group-list-groups))) | 1182 | (gnus-group-goto-group start-group) |
| 1183 | (gnus-topic-goto-topic start-topic)) | ||
| 1184 | (gnus-group-list-groups)))) | ||
| 1114 | 1185 | ||
| 1115 | (defun gnus-topic-remove-group (&optional arg) | 1186 | (defun gnus-topic-remove-group (&optional n) |
| 1116 | "Remove the current group from the topic." | 1187 | "Remove the current group from the topic." |
| 1117 | (interactive "P") | 1188 | (interactive "P") |
| 1118 | (gnus-group-iterate arg | 1189 | (let ((use-marked (and (not n) (not (gnus-region-active-p)) |
| 1119 | (lambda (group) | 1190 | gnus-group-marked t)) |
| 1120 | (let ((topicl (assoc (gnus-current-topic) gnus-topic-alist)) | 1191 | (groups (gnus-group-process-prefix n))) |
| 1121 | (buffer-read-only nil)) | 1192 | (mapcar |
| 1122 | (when (and topicl group) | 1193 | (lambda (group) |
| 1123 | (gnus-delete-line) | 1194 | (gnus-group-remove-mark group use-marked) |
| 1124 | (gnus-delete-first group topicl)) | 1195 | (let ((topicl (assoc (gnus-current-topic) gnus-topic-alist)) |
| 1125 | (gnus-topic-update-topic) | 1196 | (buffer-read-only nil)) |
| 1126 | (gnus-group-position-point))))) | 1197 | (when (and topicl group) |
| 1198 | (gnus-delete-line) | ||
| 1199 | (gnus-delete-first group topicl)) | ||
| 1200 | (gnus-topic-update-topic))) | ||
| 1201 | groups) | ||
| 1202 | (gnus-topic-enter-dribble) | ||
| 1203 | (gnus-group-position-point))) | ||
| 1127 | 1204 | ||
| 1128 | (defun gnus-topic-copy-group (n topic) | 1205 | (defun gnus-topic-copy-group (n topic) |
| 1129 | "Copy the current group to a topic." | 1206 | "Copy the current group to a topic." |
| @@ -1145,7 +1222,12 @@ If COPYP, copy the groups instead." | |||
| 1145 | (gnus-topic-find-topology topic nil nil gnus-topic-topology) | 1222 | (gnus-topic-find-topology topic nil nil gnus-topic-topology) |
| 1146 | (gnus-topic-enter-dribble)) | 1223 | (gnus-topic-enter-dribble)) |
| 1147 | (gnus-group-kill-group n discard) | 1224 | (gnus-group-kill-group n discard) |
| 1148 | (gnus-topic-update-topic))) | 1225 | (if (not (gnus-group-topic-p)) |
| 1226 | (gnus-topic-update-topic) | ||
| 1227 | ;; Move up one line so that we update the right topic. | ||
| 1228 | (forward-line -1) | ||
| 1229 | (gnus-topic-update-topic) | ||
| 1230 | (forward-line 1)))) | ||
| 1149 | 1231 | ||
| 1150 | (defun gnus-topic-yank-group (&optional arg) | 1232 | (defun gnus-topic-yank-group (&optional arg) |
| 1151 | "Yank the last topic." | 1233 | "Yank the last topic." |
| @@ -1195,43 +1277,64 @@ If COPYP, copy the groups instead." | |||
| 1195 | (setq alist (cdr alist)))))) | 1277 | (setq alist (cdr alist)))))) |
| 1196 | (gnus-topic-update-topic))) | 1278 | (gnus-topic-update-topic))) |
| 1197 | 1279 | ||
| 1198 | (defun gnus-topic-hide-topic () | 1280 | (defun gnus-topic-hide-topic (&optional permanent) |
| 1199 | "Hide the current topic." | 1281 | "Hide the current topic. |
| 1200 | (interactive) | 1282 | If PERMANENT, make it stay hidden in subsequent sessions as well." |
| 1283 | (interactive "P") | ||
| 1201 | (when (gnus-current-topic) | 1284 | (when (gnus-current-topic) |
| 1202 | (gnus-topic-goto-topic (gnus-current-topic)) | 1285 | (gnus-topic-goto-topic (gnus-current-topic)) |
| 1203 | (gnus-topic-remove-topic nil nil 'hidden))) | 1286 | (if permanent |
| 1204 | 1287 | (setcar (cddr | |
| 1205 | (defun gnus-topic-show-topic () | 1288 | (cadr |
| 1206 | "Show the hidden topic." | 1289 | (gnus-topic-find-topology (gnus-current-topic)))) |
| 1207 | (interactive) | 1290 | 'hidden)) |
| 1291 | (gnus-topic-remove-topic nil nil))) | ||
| 1292 | |||
| 1293 | (defun gnus-topic-show-topic (&optional permanent) | ||
| 1294 | "Show the hidden topic. | ||
| 1295 | If PERMANENT, make it stay shown in subsequent sessions as well." | ||
| 1296 | (interactive "P") | ||
| 1208 | (when (gnus-group-topic-p) | 1297 | (when (gnus-group-topic-p) |
| 1209 | (gnus-topic-remove-topic t nil 'shown))) | 1298 | (if (not permanent) |
| 1210 | 1299 | (gnus-topic-remove-topic t nil) | |
| 1211 | (defun gnus-topic-mark-topic (topic &optional unmark) | 1300 | (let ((topic |
| 1212 | "Mark all groups in the topic with the process mark." | 1301 | (gnus-topic-find-topology |
| 1213 | (interactive (list (gnus-group-topic-name))) | 1302 | (completing-read "Show topic: " gnus-topic-alist nil t)))) |
| 1303 | (setcar (cddr (cadr topic)) nil) | ||
| 1304 | (setcar (cdr (cadr topic)) 'visible) | ||
| 1305 | (gnus-group-list-groups))))) | ||
| 1306 | |||
| 1307 | (defun gnus-topic-mark-topic (topic &optional unmark recursive) | ||
| 1308 | "Mark all groups in the TOPIC with the process mark. | ||
| 1309 | If RECURSIVE is t, mark its subtopics too." | ||
| 1310 | (interactive (list (gnus-group-topic-name) | ||
| 1311 | nil | ||
| 1312 | (and current-prefix-arg t))) | ||
| 1214 | (if (not topic) | 1313 | (if (not topic) |
| 1215 | (call-interactively 'gnus-group-mark-group) | 1314 | (call-interactively 'gnus-group-mark-group) |
| 1216 | (save-excursion | 1315 | (save-excursion |
| 1217 | (let ((groups (gnus-topic-find-groups topic gnus-level-killed t))) | 1316 | (let ((groups (gnus-topic-find-groups topic gnus-level-killed t nil |
| 1317 | recursive))) | ||
| 1218 | (while groups | 1318 | (while groups |
| 1219 | (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark) | 1319 | (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark) |
| 1220 | (gnus-info-group (nth 2 (pop groups))))))))) | 1320 | (gnus-info-group (nth 2 (pop groups))))))))) |
| 1221 | 1321 | ||
| 1222 | (defun gnus-topic-unmark-topic (topic &optional unmark) | 1322 | (defun gnus-topic-unmark-topic (topic &optional dummy recursive) |
| 1223 | "Remove the process mark from all groups in the topic." | 1323 | "Remove the process mark from all groups in the TOPIC. |
| 1224 | (interactive (list (gnus-group-topic-name))) | 1324 | If RECURSIVE is t, unmark its subtopics too." |
| 1325 | (interactive (list (gnus-group-topic-name) | ||
| 1326 | nil | ||
| 1327 | (and current-prefix-arg t))) | ||
| 1225 | (if (not topic) | 1328 | (if (not topic) |
| 1226 | (call-interactively 'gnus-group-unmark-group) | 1329 | (call-interactively 'gnus-group-unmark-group) |
| 1227 | (gnus-topic-mark-topic topic t))) | 1330 | (gnus-topic-mark-topic topic t recursive))) |
| 1228 | 1331 | ||
| 1229 | (defun gnus-topic-get-new-news-this-topic (&optional n) | 1332 | (defun gnus-topic-get-new-news-this-topic (&optional n) |
| 1230 | "Check for new news in the current topic." | 1333 | "Check for new news in the current topic." |
| 1231 | (interactive "P") | 1334 | (interactive "P") |
| 1232 | (if (not (gnus-group-topic-p)) | 1335 | (if (not (gnus-group-topic-p)) |
| 1233 | (gnus-group-get-new-news-this-group n) | 1336 | (gnus-group-get-new-news-this-group n) |
| 1234 | (gnus-topic-mark-topic (gnus-group-topic-name)) | 1337 | (gnus-topic-mark-topic (gnus-group-topic-name) nil (and n t)) |
| 1235 | (gnus-group-get-new-news-this-group))) | 1338 | (gnus-group-get-new-news-this-group))) |
| 1236 | 1339 | ||
| 1237 | (defun gnus-topic-move-matching (regexp topic &optional copyp) | 1340 | (defun gnus-topic-move-matching (regexp topic &optional copyp) |
| @@ -1450,6 +1553,68 @@ If REVERSE, sort in reverse order." | |||
| 1450 | (interactive "P") | 1553 | (interactive "P") |
| 1451 | (gnus-topic-sort-groups 'gnus-group-sort-by-method reverse)) | 1554 | (gnus-topic-sort-groups 'gnus-group-sort-by-method reverse)) |
| 1452 | 1555 | ||
| 1556 | (defun gnus-topic-sort-topics-1 (top reverse) | ||
| 1557 | (if (cdr top) | ||
| 1558 | (let ((subtop | ||
| 1559 | (mapcar `(lambda (top) | ||
| 1560 | (gnus-topic-sort-topics-1 top ,reverse)) | ||
| 1561 | (sort (cdr top) | ||
| 1562 | '(lambda (t1 t2) | ||
| 1563 | (string-lessp (caar t1) (caar t2))))))) | ||
| 1564 | (setcdr top (if reverse (reverse subtop) subtop)))) | ||
| 1565 | top) | ||
| 1566 | |||
| 1567 | (defun gnus-topic-sort-topics (&optional topic reverse) | ||
| 1568 | "Sort topics in TOPIC alphabeticaly by topic name. | ||
| 1569 | If REVERSE, reverse the sorting order." | ||
| 1570 | (interactive | ||
| 1571 | (list (completing-read "Sort topics in : " gnus-topic-alist nil t | ||
| 1572 | (gnus-current-topic)) | ||
| 1573 | current-prefix-arg)) | ||
| 1574 | (let ((topic-topology (or (and topic (cdr (gnus-topic-find-topology topic))) | ||
| 1575 | gnus-topic-topology))) | ||
| 1576 | (gnus-topic-sort-topics-1 topic-topology reverse) | ||
| 1577 | (gnus-topic-enter-dribble) | ||
| 1578 | (gnus-group-list-groups) | ||
| 1579 | (gnus-topic-goto-topic topic))) | ||
| 1580 | |||
| 1581 | (defun gnus-topic-move (current to) | ||
| 1582 | "Move the CURRENT topic to TO." | ||
| 1583 | (interactive | ||
| 1584 | (list | ||
| 1585 | (gnus-group-topic-name) | ||
| 1586 | (completing-read "Move to topic: " gnus-topic-alist nil t))) | ||
| 1587 | (unless (and current to) | ||
| 1588 | (error "Can't find topic")) | ||
| 1589 | (let ((current-top (cdr (gnus-topic-find-topology current))) | ||
| 1590 | (to-top (cdr (gnus-topic-find-topology to)))) | ||
| 1591 | (unless current-top | ||
| 1592 | (error "Can't find topic `%s'" current)) | ||
| 1593 | (unless to-top | ||
| 1594 | (error "Can't find topic `%s'" to)) | ||
| 1595 | (if (gnus-topic-find-topology to current-top 0);; Don't care the level | ||
| 1596 | (error "Can't move `%s' to its sub-level" current)) | ||
| 1597 | (gnus-topic-find-topology current nil nil 'delete) | ||
| 1598 | (while (cdr to-top) | ||
| 1599 | (setq to-top (cdr to-top))) | ||
| 1600 | (setcdr to-top (list current-top)) | ||
| 1601 | (gnus-topic-enter-dribble) | ||
| 1602 | (gnus-group-list-groups) | ||
| 1603 | (gnus-topic-goto-topic current))) | ||
| 1604 | |||
| 1605 | (defun gnus-subscribe-topics (newsgroup) | ||
| 1606 | (catch 'end | ||
| 1607 | (let (match gnus-group-change-level-function) | ||
| 1608 | (dolist (topic (gnus-topic-list)) | ||
| 1609 | (when (and (setq match (cdr (assq 'subscribe | ||
| 1610 | (gnus-topic-parameters topic)))) | ||
| 1611 | (string-match match newsgroup)) | ||
| 1612 | ;; Just subscribe the group. | ||
| 1613 | (gnus-subscribe-alphabetically newsgroup) | ||
| 1614 | ;; Add the group to the topic. | ||
| 1615 | (nconc (assoc topic gnus-topic-alist) (list newsgroup)) | ||
| 1616 | (throw 'end t)))))) | ||
| 1617 | |||
| 1453 | (provide 'gnus-topic) | 1618 | (provide 'gnus-topic) |
| 1454 | 1619 | ||
| 1455 | ;;; gnus-topic.el ends here | 1620 | ;;; gnus-topic.el ends here |
diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index 8885fbd8719..72e4d031e1c 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el | |||
| @@ -1,5 +1,6 @@ | |||
| 1 | ;;; gnus-util.el --- utility functions for Gnus | 1 | ;;; gnus-util.el --- utility functions for Gnus |
| 2 | ;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. | 2 | ;; Copyright (C) 1996, 1997, 1998, 1999, 2000 |
| 3 | ;; Free Software Foundation, Inc. | ||
| 3 | 4 | ||
| 4 | ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> | 5 | ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
| 5 | ;; Keywords: news | 6 | ;; Keywords: news |
| @@ -33,12 +34,10 @@ | |||
| 33 | (require 'custom) | 34 | (require 'custom) |
| 34 | (eval-when-compile (require 'cl)) | 35 | (eval-when-compile (require 'cl)) |
| 35 | (require 'nnheader) | 36 | (require 'nnheader) |
| 36 | (require 'timezone) | ||
| 37 | (require 'message) | 37 | (require 'message) |
| 38 | (eval-when-compile (require 'rmail)) | 38 | (require 'time-date) |
| 39 | 39 | ||
| 40 | (eval-and-compile | 40 | (eval-and-compile |
| 41 | (autoload 'nnmail-date-to-time "nnmail") | ||
| 42 | (autoload 'rmail-insert-rmail-file-header "rmail") | 41 | (autoload 'rmail-insert-rmail-file-header "rmail") |
| 43 | (autoload 'rmail-count-new-messages "rmail") | 42 | (autoload 'rmail-count-new-messages "rmail") |
| 44 | (autoload 'rmail-show-message "rmail")) | 43 | (autoload 'rmail-show-message "rmail")) |
| @@ -76,9 +75,6 @@ | |||
| 76 | (set symbol nil)) | 75 | (set symbol nil)) |
| 77 | symbol)) | 76 | symbol)) |
| 78 | 77 | ||
| 79 | (defun gnus-truncate-string (str width) | ||
| 80 | (substring str 0 width)) | ||
| 81 | |||
| 82 | ;; Added by Geoffrey T. Dairiki <dairiki@u.washington.edu>. A safe way | 78 | ;; Added by Geoffrey T. Dairiki <dairiki@u.washington.edu>. A safe way |
| 83 | ;; to limit the length of a string. This function is necessary since | 79 | ;; to limit the length of a string. This function is necessary since |
| 84 | ;; `(substr "abc" 0 30)' pukes with "Args out of range". | 80 | ;; `(substr "abc" 0 30)' pukes with "Args out of range". |
| @@ -107,25 +103,15 @@ | |||
| 107 | (when (gnus-buffer-exists-p buf) | 103 | (when (gnus-buffer-exists-p buf) |
| 108 | (kill-buffer buf)))) | 104 | (kill-buffer buf)))) |
| 109 | 105 | ||
| 110 | (if (fboundp 'point-at-bol) | 106 | (defalias 'gnus-point-at-bol |
| 111 | (fset 'gnus-point-at-bol 'point-at-bol) | 107 | (if (fboundp 'point-at-bol) |
| 112 | (defun gnus-point-at-bol () | 108 | 'point-at-bol |
| 113 | "Return point at the beginning of the line." | 109 | 'line-beginning-position)) |
| 114 | (let ((p (point))) | 110 | |
| 115 | (beginning-of-line) | 111 | (defalias 'gnus-point-at-eol |
| 116 | (prog1 | 112 | (if (fboundp 'point-at-eol) |
| 117 | (point) | 113 | 'point-at-eol |
| 118 | (goto-char p))))) | 114 | 'line-end-position)) |
| 119 | |||
| 120 | (if (fboundp 'point-at-eol) | ||
| 121 | (fset 'gnus-point-at-eol 'point-at-eol) | ||
| 122 | (defun gnus-point-at-eol () | ||
| 123 | "Return point at the end of the line." | ||
| 124 | (let ((p (point))) | ||
| 125 | (end-of-line) | ||
| 126 | (prog1 | ||
| 127 | (point) | ||
| 128 | (goto-char p))))) | ||
| 129 | 115 | ||
| 130 | (defun gnus-delete-first (elt list) | 116 | (defun gnus-delete-first (elt list) |
| 131 | "Delete by side effect the first occurrence of ELT as a member of LIST." | 117 | "Delete by side effect the first occurrence of ELT as a member of LIST." |
| @@ -179,8 +165,8 @@ | |||
| 179 | (and (string-match "(.*" from) | 165 | (and (string-match "(.*" from) |
| 180 | (setq name (substring from (1+ (match-beginning 0)) | 166 | (setq name (substring from (1+ (match-beginning 0)) |
| 181 | (match-end 0))))) | 167 | (match-end 0))))) |
| 182 | ;; Fix by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>. | 168 | (list (if (string= name "") nil name) (or address from)))) |
| 183 | (list (or name from) (or address from)))) | 169 | |
| 184 | 170 | ||
| 185 | (defun gnus-fetch-field (field) | 171 | (defun gnus-fetch-field (field) |
| 186 | "Return the value of the header FIELD of current article." | 172 | "Return the value of the header FIELD of current article." |
| @@ -232,43 +218,6 @@ | |||
| 232 | 218 | ||
| 233 | ;;; Time functions. | 219 | ;;; Time functions. |
| 234 | 220 | ||
| 235 | (defun gnus-days-between (date1 date2) | ||
| 236 | ;; Return the number of days between date1 and date2. | ||
| 237 | (- (gnus-day-number date1) (gnus-day-number date2))) | ||
| 238 | |||
| 239 | (defun gnus-day-number (date) | ||
| 240 | (let ((dat (mapcar (lambda (s) (and s (string-to-int s)) ) | ||
| 241 | (timezone-parse-date date)))) | ||
| 242 | (timezone-absolute-from-gregorian | ||
| 243 | (nth 1 dat) (nth 2 dat) (car dat)))) | ||
| 244 | |||
| 245 | (defun gnus-time-to-day (time) | ||
| 246 | "Convert TIME to day number." | ||
| 247 | (let ((tim (decode-time time))) | ||
| 248 | (timezone-absolute-from-gregorian | ||
| 249 | (nth 4 tim) (nth 3 tim) (nth 5 tim)))) | ||
| 250 | |||
| 251 | (defun gnus-encode-date (date) | ||
| 252 | "Convert DATE to internal time." | ||
| 253 | (let* ((parse (timezone-parse-date date)) | ||
| 254 | (date (mapcar (lambda (d) (and d (string-to-int d))) parse)) | ||
| 255 | (time (mapcar 'string-to-int (timezone-parse-time (aref parse 3))))) | ||
| 256 | (encode-time (caddr time) (cadr time) (car time) | ||
| 257 | (caddr date) (cadr date) (car date) | ||
| 258 | (* 60 (timezone-zone-to-minute (nth 4 date)))))) | ||
| 259 | |||
| 260 | (defun gnus-time-minus (t1 t2) | ||
| 261 | "Subtract two internal times." | ||
| 262 | (let ((borrow (< (cadr t1) (cadr t2)))) | ||
| 263 | (list (- (car t1) (car t2) (if borrow 1 0)) | ||
| 264 | (- (+ (if borrow 65536 0) (cadr t1)) (cadr t2))))) | ||
| 265 | |||
| 266 | (defun gnus-time-less (t1 t2) | ||
| 267 | "Say whether time T1 is less than time T2." | ||
| 268 | (or (< (car t1) (car t2)) | ||
| 269 | (and (= (car t1) (car t2)) | ||
| 270 | (< (nth 1 t1) (nth 1 t2))))) | ||
| 271 | |||
| 272 | (defun gnus-file-newer-than (file date) | 221 | (defun gnus-file-newer-than (file date) |
| 273 | (let ((fdate (nth 5 (file-attributes file)))) | 222 | (let ((fdate (nth 5 (file-attributes file)))) |
| 274 | (or (> (car fdate) (car date)) | 223 | (or (> (car fdate) (car date)) |
| @@ -343,20 +292,9 @@ | |||
| 343 | 292 | ||
| 344 | (defun gnus-dd-mmm (messy-date) | 293 | (defun gnus-dd-mmm (messy-date) |
| 345 | "Return a string like DD-MMM from a big messy string." | 294 | "Return a string like DD-MMM from a big messy string." |
| 346 | (let ((datevec (ignore-errors (timezone-parse-date messy-date)))) | 295 | (condition-case () |
| 347 | (if (or (not datevec) | 296 | (format-time-string "%d-%b" (safe-date-to-time messy-date)) |
| 348 | (string-equal "0" (aref datevec 1))) | 297 | (error " - "))) |
| 349 | "??-???" | ||
| 350 | (format "%2s-%s" | ||
| 351 | (condition-case () | ||
| 352 | ;; Make sure leading zeroes are stripped. | ||
| 353 | (number-to-string (string-to-number (aref datevec 2))) | ||
| 354 | (error "??")) | ||
| 355 | (capitalize | ||
| 356 | (or (car | ||
| 357 | (nth (1- (string-to-number (aref datevec 1))) | ||
| 358 | timezone-months-assoc)) | ||
| 359 | "???")))))) | ||
| 360 | 298 | ||
| 361 | (defmacro gnus-date-get-time (date) | 299 | (defmacro gnus-date-get-time (date) |
| 362 | "Convert DATE string to Emacs time. | 300 | "Convert DATE string to Emacs time. |
| @@ -367,17 +305,17 @@ Cache the result as a text property stored in DATE." | |||
| 367 | '(0 0) | 305 | '(0 0) |
| 368 | (or (get-text-property 0 'gnus-time d) | 306 | (or (get-text-property 0 'gnus-time d) |
| 369 | ;; or compute the value... | 307 | ;; or compute the value... |
| 370 | (let ((time (nnmail-date-to-time d))) | 308 | (let ((time (safe-date-to-time d))) |
| 371 | ;; and store it back in the string. | 309 | ;; and store it back in the string. |
| 372 | (put-text-property 0 1 'gnus-time time d) | 310 | (put-text-property 0 1 'gnus-time time d) |
| 373 | time))))) | 311 | time))))) |
| 374 | 312 | ||
| 375 | (defsubst gnus-time-iso8601 (time) | 313 | (defsubst gnus-time-iso8601 (time) |
| 376 | "Return a string of TIME in YYMMDDTHHMMSS format." | 314 | "Return a string of TIME in YYYYMMDDTHHMMSS format." |
| 377 | (format-time-string "%Y%m%dT%H%M%S" time)) | 315 | (format-time-string "%Y%m%dT%H%M%S" time)) |
| 378 | 316 | ||
| 379 | (defun gnus-date-iso8601 (date) | 317 | (defun gnus-date-iso8601 (date) |
| 380 | "Convert the DATE to YYMMDDTHHMMSS." | 318 | "Convert the DATE to YYYYMMDDTHHMMSS." |
| 381 | (condition-case () | 319 | (condition-case () |
| 382 | (gnus-time-iso8601 (gnus-date-get-time date)) | 320 | (gnus-time-iso8601 (gnus-date-get-time date)) |
| 383 | (error ""))) | 321 | (error ""))) |
| @@ -451,12 +389,14 @@ jabbering all the time." | |||
| 451 | ids)) | 389 | ids)) |
| 452 | (nreverse ids))) | 390 | (nreverse ids))) |
| 453 | 391 | ||
| 454 | (defun gnus-parent-id (references &optional n) | 392 | (defsubst gnus-parent-id (references &optional n) |
| 455 | "Return the last Message-ID in REFERENCES. | 393 | "Return the last Message-ID in REFERENCES. |
| 456 | If N, return the Nth ancestor instead." | 394 | If N, return the Nth ancestor instead." |
| 457 | (when references | 395 | (when references |
| 458 | (let ((ids (inline (gnus-split-references references)))) | 396 | (let ((ids (inline (gnus-split-references references)))) |
| 459 | (car (last ids (or n 1)))))) | 397 | (while (nthcdr (or n 1) ids) |
| 398 | (setq ids (cdr ids))) | ||
| 399 | (car ids)))) | ||
| 460 | 400 | ||
| 461 | (defsubst gnus-buffer-live-p (buffer) | 401 | (defsubst gnus-buffer-live-p (buffer) |
| 462 | "Say whether BUFFER is alive or not." | 402 | "Say whether BUFFER is alive or not." |
| @@ -496,20 +436,8 @@ If N, return the Nth ancestor instead." | |||
| 496 | (cons (and (numberp event) event) event))) | 436 | (cons (and (numberp event) event) event))) |
| 497 | 437 | ||
| 498 | (defun gnus-sortable-date (date) | 438 | (defun gnus-sortable-date (date) |
| 499 | "Make sortable string by string-lessp from DATE. | 439 | "Make string suitable for sorting from DATE." |
| 500 | Timezone package is used." | 440 | (gnus-time-iso8601 (date-to-time date))) |
| 501 | (condition-case () | ||
| 502 | (progn | ||
| 503 | (setq date (inline (timezone-fix-time | ||
| 504 | date nil | ||
| 505 | (aref (inline (timezone-parse-date date)) 4)))) | ||
| 506 | (inline | ||
| 507 | (timezone-make-sortable-date | ||
| 508 | (aref date 0) (aref date 1) (aref date 2) | ||
| 509 | (inline | ||
| 510 | (timezone-make-time-string | ||
| 511 | (aref date 3) (aref date 4) (aref date 5)))))) | ||
| 512 | (error ""))) | ||
| 513 | 441 | ||
| 514 | (defun gnus-copy-file (file &optional to) | 442 | (defun gnus-copy-file (file &optional to) |
| 515 | "Copy FILE to TO." | 443 | "Copy FILE to TO." |
| @@ -541,7 +469,7 @@ Timezone package is used." | |||
| 541 | (erase-buffer)) | 469 | (erase-buffer)) |
| 542 | (set-buffer (gnus-get-buffer-create gnus-work-buffer)) | 470 | (set-buffer (gnus-get-buffer-create gnus-work-buffer)) |
| 543 | (kill-all-local-variables) | 471 | (kill-all-local-variables) |
| 544 | (buffer-disable-undo (current-buffer)))) | 472 | (mm-enable-multibyte))) |
| 545 | 473 | ||
| 546 | (defmacro gnus-group-real-name (group) | 474 | (defmacro gnus-group-real-name (group) |
| 547 | "Find the real name of a foreign newsgroup." | 475 | "Find the real name of a foreign newsgroup." |
| @@ -553,21 +481,41 @@ Timezone package is used." | |||
| 553 | (defun gnus-make-sort-function (funs) | 481 | (defun gnus-make-sort-function (funs) |
| 554 | "Return a composite sort condition based on the functions in FUNC." | 482 | "Return a composite sort condition based on the functions in FUNC." |
| 555 | (cond | 483 | (cond |
| 556 | ((not (listp funs)) funs) | 484 | ;; Just a simple function. |
| 485 | ((gnus-functionp funs) funs) | ||
| 486 | ;; No functions at all. | ||
| 557 | ((null funs) funs) | 487 | ((null funs) funs) |
| 558 | ((cdr funs) | 488 | ;; A list of functions. |
| 489 | ((or (cdr funs) | ||
| 490 | (listp (car funs))) | ||
| 559 | `(lambda (t1 t2) | 491 | `(lambda (t1 t2) |
| 560 | ,(gnus-make-sort-function-1 (reverse funs)))) | 492 | ,(gnus-make-sort-function-1 (reverse funs)))) |
| 493 | ;; A list containing just one function. | ||
| 561 | (t | 494 | (t |
| 562 | (car funs)))) | 495 | (car funs)))) |
| 563 | 496 | ||
| 564 | (defun gnus-make-sort-function-1 (funs) | 497 | (defun gnus-make-sort-function-1 (funs) |
| 565 | "Return a composite sort condition based on the functions in FUNC." | 498 | "Return a composite sort condition based on the functions in FUNC." |
| 566 | (if (cdr funs) | 499 | (let ((function (car funs)) |
| 567 | `(or (,(car funs) t1 t2) | 500 | (first 't1) |
| 568 | (and (not (,(car funs) t2 t1)) | 501 | (last 't2)) |
| 569 | ,(gnus-make-sort-function-1 (cdr funs)))) | 502 | (when (consp function) |
| 570 | `(,(car funs) t1 t2))) | 503 | (cond |
| 504 | ;; Reversed spec. | ||
| 505 | ((eq (car function) 'not) | ||
| 506 | (setq function (cadr function) | ||
| 507 | first 't2 | ||
| 508 | last 't1)) | ||
| 509 | ((gnus-functionp function) | ||
| 510 | ;; Do nothing. | ||
| 511 | ) | ||
| 512 | (t | ||
| 513 | (error "Invalid sort spec: %s" function)))) | ||
| 514 | (if (cdr funs) | ||
| 515 | `(or (,function ,first ,last) | ||
| 516 | (and (not (,function ,last ,first)) | ||
| 517 | ,(gnus-make-sort-function-1 (cdr funs)))) | ||
| 518 | `(,function ,first ,last)))) | ||
| 571 | 519 | ||
| 572 | (defun gnus-turn-off-edit-menu (type) | 520 | (defun gnus-turn-off-edit-menu (type) |
| 573 | "Turn off edit menu in `gnus-TYPE-mode-map'." | 521 | "Turn off edit menu in `gnus-TYPE-mode-map'." |
| @@ -591,17 +539,19 @@ Bind `print-quoted' and `print-readably' to t while printing." | |||
| 591 | 539 | ||
| 592 | (defun gnus-make-directory (directory) | 540 | (defun gnus-make-directory (directory) |
| 593 | "Make DIRECTORY (and all its parents) if it doesn't exist." | 541 | "Make DIRECTORY (and all its parents) if it doesn't exist." |
| 594 | (when (and directory | 542 | (let ((file-name-coding-system nnmail-pathname-coding-system)) |
| 595 | (not (file-exists-p directory))) | 543 | (when (and directory |
| 596 | (make-directory directory t)) | 544 | (not (file-exists-p directory))) |
| 545 | (make-directory directory t))) | ||
| 597 | t) | 546 | t) |
| 598 | 547 | ||
| 599 | (defun gnus-write-buffer (file) | 548 | (defun gnus-write-buffer (file) |
| 600 | "Write the current buffer's contents to FILE." | 549 | "Write the current buffer's contents to FILE." |
| 601 | ;; Make sure the directory exists. | 550 | ;; Make sure the directory exists. |
| 602 | (gnus-make-directory (file-name-directory file)) | 551 | (gnus-make-directory (file-name-directory file)) |
| 603 | ;; Write the buffer. | 552 | (let ((file-name-coding-system nnmail-pathname-coding-system)) |
| 604 | (write-region (point-min) (point-max) file nil 'quietly)) | 553 | ;; Write the buffer. |
| 554 | (write-region (point-min) (point-max) file nil 'quietly))) | ||
| 605 | 555 | ||
| 606 | (defun gnus-delete-file (file) | 556 | (defun gnus-delete-file (file) |
| 607 | "Delete FILE if it exists." | 557 | "Delete FILE if it exists." |
| @@ -614,13 +564,13 @@ Bind `print-quoted' and `print-readably' to t while printing." | |||
| 614 | (setq string (replace-match "" t t string))) | 564 | (setq string (replace-match "" t t string))) |
| 615 | string) | 565 | string) |
| 616 | 566 | ||
| 617 | (defun gnus-put-text-property-excluding-newlines (beg end prop val) | 567 | (defsubst gnus-put-text-property-excluding-newlines (beg end prop val) |
| 618 | "The same as `put-text-property', but don't put this prop on any newlines in the region." | 568 | "The same as `put-text-property', but don't put this prop on any newlines in the region." |
| 619 | (save-match-data | 569 | (save-match-data |
| 620 | (save-excursion | 570 | (save-excursion |
| 621 | (save-restriction | 571 | (save-restriction |
| 622 | (goto-char beg) | 572 | (goto-char beg) |
| 623 | (while (re-search-forward "[ \t]*\n" end 'move) | 573 | (while (re-search-forward gnus-emphasize-whitespace-regexp end 'move) |
| 624 | (gnus-put-text-property beg (match-beginning 0) prop val) | 574 | (gnus-put-text-property beg (match-beginning 0) prop val) |
| 625 | (setq beg (point))) | 575 | (setq beg (point))) |
| 626 | (gnus-put-text-property beg (point) prop val))))) | 576 | (gnus-put-text-property beg (point) prop val))))) |
| @@ -733,7 +683,8 @@ with potentially long computations." | |||
| 733 | (save-excursion | 683 | (save-excursion |
| 734 | (set-buffer file-buffer) | 684 | (set-buffer file-buffer) |
| 735 | (rmail-insert-rmail-file-header) | 685 | (rmail-insert-rmail-file-header) |
| 736 | (let ((require-final-newline nil)) | 686 | (let ((require-final-newline nil) |
| 687 | (coding-system-for-write mm-text-coding-system)) | ||
| 737 | (gnus-write-buffer filename))) | 688 | (gnus-write-buffer filename))) |
| 738 | (kill-buffer file-buffer)) | 689 | (kill-buffer file-buffer)) |
| 739 | (error "Output file does not exist"))) | 690 | (error "Output file does not exist"))) |
| @@ -744,7 +695,7 @@ with potentially long computations." | |||
| 744 | ;; Decide whether to append to a file or to an Emacs buffer. | 695 | ;; Decide whether to append to a file or to an Emacs buffer. |
| 745 | (let ((outbuf (get-file-buffer filename))) | 696 | (let ((outbuf (get-file-buffer filename))) |
| 746 | (if (not outbuf) | 697 | (if (not outbuf) |
| 747 | (append-to-file (point-min) (point-max) filename) | 698 | (mm-append-to-file (point-min) (point-max) filename) |
| 748 | ;; File has been visited, in buffer OUTBUF. | 699 | ;; File has been visited, in buffer OUTBUF. |
| 749 | (set-buffer outbuf) | 700 | (set-buffer outbuf) |
| 750 | (let ((buffer-read-only nil) | 701 | (let ((buffer-read-only nil) |
| @@ -784,7 +735,8 @@ with potentially long computations." | |||
| 784 | (let ((file-buffer (create-file-buffer filename))) | 735 | (let ((file-buffer (create-file-buffer filename))) |
| 785 | (save-excursion | 736 | (save-excursion |
| 786 | (set-buffer file-buffer) | 737 | (set-buffer file-buffer) |
| 787 | (let ((require-final-newline nil)) | 738 | (let ((require-final-newline nil) |
| 739 | (coding-system-for-write mm-text-coding-system)) | ||
| 788 | (gnus-write-buffer filename))) | 740 | (gnus-write-buffer filename))) |
| 789 | (kill-buffer file-buffer)) | 741 | (kill-buffer file-buffer)) |
| 790 | (error "Output file does not exist"))) | 742 | (error "Output file does not exist"))) |
| @@ -812,7 +764,7 @@ with potentially long computations." | |||
| 812 | (insert "\n")) | 764 | (insert "\n")) |
| 813 | (insert "\n")) | 765 | (insert "\n")) |
| 814 | (goto-char (point-max)) | 766 | (goto-char (point-max)) |
| 815 | (append-to-file (point-min) (point-max) filename))) | 767 | (mm-append-to-file (point-min) (point-max) filename))) |
| 816 | ;; File has been visited, in buffer OUTBUF. | 768 | ;; File has been visited, in buffer OUTBUF. |
| 817 | (set-buffer outbuf) | 769 | (set-buffer outbuf) |
| 818 | (let ((buffer-read-only nil)) | 770 | (let ((buffer-read-only nil)) |
| @@ -853,84 +805,84 @@ ARG is passed to the first function." | |||
| 853 | ;;; .netrc and .authinforc parsing | 805 | ;;; .netrc and .authinforc parsing |
| 854 | ;;; | 806 | ;;; |
| 855 | 807 | ||
| 856 | (defvar gnus-netrc-syntax-table | ||
| 857 | (let ((table (copy-syntax-table text-mode-syntax-table))) | ||
| 858 | (modify-syntax-entry ?@ "w" table) | ||
| 859 | (modify-syntax-entry ?- "w" table) | ||
| 860 | (modify-syntax-entry ?_ "w" table) | ||
| 861 | (modify-syntax-entry ?! "w" table) | ||
| 862 | (modify-syntax-entry ?. "w" table) | ||
| 863 | (modify-syntax-entry ?, "w" table) | ||
| 864 | (modify-syntax-entry ?: "w" table) | ||
| 865 | (modify-syntax-entry ?\; "w" table) | ||
| 866 | (modify-syntax-entry ?% "w" table) | ||
| 867 | (modify-syntax-entry ?) "w" table) | ||
| 868 | (modify-syntax-entry ?( "w" table) | ||
| 869 | table) | ||
| 870 | "Syntax table when parsing .netrc files.") | ||
| 871 | |||
| 872 | (defun gnus-parse-netrc (file) | 808 | (defun gnus-parse-netrc (file) |
| 873 | "Parse FILE and return an list of all entries in the file." | 809 | "Parse FILE and return an list of all entries in the file." |
| 874 | (if (not (file-exists-p file)) | 810 | (when (file-exists-p file) |
| 875 | () | 811 | (with-temp-buffer |
| 876 | (save-excursion | ||
| 877 | (let ((tokens '("machine" "default" "login" | 812 | (let ((tokens '("machine" "default" "login" |
| 878 | "password" "account" "macdef" "force")) | 813 | "password" "account" "macdef" "force" |
| 814 | "port")) | ||
| 879 | alist elem result pair) | 815 | alist elem result pair) |
| 880 | (nnheader-set-temp-buffer " *netrc*") | 816 | (insert-file-contents file) |
| 881 | (unwind-protect | 817 | (goto-char (point-min)) |
| 882 | (progn | 818 | ;; Go through the file, line by line. |
| 883 | (set-syntax-table gnus-netrc-syntax-table) | 819 | (while (not (eobp)) |
| 884 | (insert-file-contents file) | 820 | (narrow-to-region (point) (gnus-point-at-eol)) |
| 885 | (goto-char (point-min)) | 821 | ;; For each line, get the tokens and values. |
| 886 | ;; Go through the file, line by line. | 822 | (while (not (eobp)) |
| 887 | (while (not (eobp)) | 823 | (skip-chars-forward "\t ") |
| 888 | (narrow-to-region (point) (gnus-point-at-eol)) | 824 | ;; Skip lines that begin with a "#". |
| 889 | ;; For each line, get the tokens and values. | 825 | (if (eq (char-after) ?#) |
| 890 | (while (not (eobp)) | 826 | (goto-char (point-max)) |
| 891 | (skip-chars-forward "\t ") | 827 | (unless (eobp) |
| 892 | (unless (eobp) | 828 | (setq elem |
| 893 | (setq elem (buffer-substring | 829 | (if (= (following-char) ?\") |
| 894 | (point) (progn (forward-sexp 1) (point)))) | 830 | (read (current-buffer)) |
| 895 | (cond | 831 | (buffer-substring |
| 896 | ((equal elem "macdef") | 832 | (point) (progn (skip-chars-forward "^\t ") |
| 897 | ;; We skip past the macro definition. | 833 | (point))))) |
| 898 | (widen) | 834 | (cond |
| 899 | (while (and (zerop (forward-line 1)) | 835 | ((equal elem "macdef") |
| 900 | (looking-at "$"))) | 836 | ;; We skip past the macro definition. |
| 901 | (narrow-to-region (point) (point))) | 837 | (widen) |
| 902 | ((member elem tokens) | 838 | (while (and (zerop (forward-line 1)) |
| 903 | ;; Tokens that don't have a following value are ignored, | 839 | (looking-at "$"))) |
| 904 | ;; except "default". | 840 | (narrow-to-region (point) (point))) |
| 905 | (when (and pair (or (cdr pair) | 841 | ((member elem tokens) |
| 906 | (equal (car pair) "default"))) | 842 | ;; Tokens that don't have a following value are ignored, |
| 907 | (push pair alist)) | 843 | ;; except "default". |
| 908 | (setq pair (list elem))) | 844 | (when (and pair (or (cdr pair) |
| 909 | (t | 845 | (equal (car pair) "default"))) |
| 910 | ;; Values that haven't got a preceding token are ignored. | 846 | (push pair alist)) |
| 911 | (when pair | 847 | (setq pair (list elem))) |
| 912 | (setcdr pair elem) | 848 | (t |
| 913 | (push pair alist) | 849 | ;; Values that haven't got a preceding token are ignored. |
| 914 | (setq pair nil)))))) | 850 | (when pair |
| 915 | (if alist | 851 | (setcdr pair elem) |
| 916 | (push (nreverse alist) result)) | 852 | (push pair alist) |
| 917 | (setq alist nil | 853 | (setq pair nil))))))) |
| 918 | pair nil) | 854 | (when alist |
| 919 | (widen) | 855 | (push (nreverse alist) result)) |
| 920 | (forward-line 1)) | 856 | (setq alist nil |
| 921 | (nreverse result)) | 857 | pair nil) |
| 922 | (kill-buffer " *netrc*")))))) | 858 | (widen) |
| 923 | 859 | (forward-line 1)) | |
| 924 | (defun gnus-netrc-machine (list machine) | 860 | (nreverse result))))) |
| 925 | "Return the netrc values from LIST for MACHINE or for the default entry." | 861 | |
| 926 | (let ((rest list)) | 862 | (defun gnus-netrc-machine (list machine &optional port defaultport) |
| 927 | (while (and list | 863 | "Return the netrc values from LIST for MACHINE or for the default entry. |
| 928 | (not (equal (cdr (assoc "machine" (car list))) machine))) | 864 | If PORT specified, only return entries with matching port tokens. |
| 865 | Entries without port tokens default to DEFAULTPORT." | ||
| 866 | (let ((rest list) | ||
| 867 | result) | ||
| 868 | (while list | ||
| 869 | (when (equal (cdr (assoc "machine" (car list))) machine) | ||
| 870 | (push (car list) result)) | ||
| 929 | (pop list)) | 871 | (pop list)) |
| 930 | (car (or list | 872 | (unless result |
| 931 | (progn (while (and rest (not (assoc "default" (car rest)))) | 873 | ;; No machine name matches, so we look for default entries. |
| 932 | (pop rest)) | 874 | (while rest |
| 933 | rest))))) | 875 | (when (assoc "default" (car rest)) |
| 876 | (push (car rest) result)) | ||
| 877 | (pop rest))) | ||
| 878 | (when result | ||
| 879 | (setq result (nreverse result)) | ||
| 880 | (while (and result | ||
| 881 | (not (equal (or port defaultport "nntp") | ||
| 882 | (or (gnus-netrc-get (car result) "port") | ||
| 883 | defaultport "nntp")))) | ||
| 884 | (pop result)) | ||
| 885 | (car result)))) | ||
| 934 | 886 | ||
| 935 | (defun gnus-netrc-get (alist type) | 887 | (defun gnus-netrc-get (alist type) |
| 936 | "Return the value of token TYPE from ALIST." | 888 | "Return the value of token TYPE from ALIST." |
| @@ -938,7 +890,7 @@ ARG is passed to the first function." | |||
| 938 | 890 | ||
| 939 | ;;; Various | 891 | ;;; Various |
| 940 | 892 | ||
| 941 | (defvar gnus-group-buffer) ; Compiler directive | 893 | (defvar gnus-group-buffer) ; Compiler directive |
| 942 | (defun gnus-alive-p () | 894 | (defun gnus-alive-p () |
| 943 | "Say whether Gnus is running or not." | 895 | "Say whether Gnus is running or not." |
| 944 | (and (boundp 'gnus-group-buffer) | 896 | (and (boundp 'gnus-group-buffer) |
| @@ -971,11 +923,12 @@ ARG is passed to the first function." | |||
| 971 | (setq alist (delq entry alist))) | 923 | (setq alist (delq entry alist))) |
| 972 | alist)) | 924 | alist)) |
| 973 | 925 | ||
| 974 | (defmacro gnus-pull (key alist) | 926 | (defmacro gnus-pull (key alist &optional assoc-p) |
| 975 | "Modify ALIST to be without KEY." | 927 | "Modify ALIST to be without KEY." |
| 976 | (unless (symbolp alist) | 928 | (unless (symbolp alist) |
| 977 | (error "Not a symbol: %s" alist)) | 929 | (error "Not a symbol: %s" alist)) |
| 978 | `(setq ,alist (delq (assq ,key ,alist) ,alist))) | 930 | (let ((fun (if assoc-p 'assoc 'assq))) |
| 931 | `(setq ,alist (delq (,fun ,key ,alist) ,alist)))) | ||
| 979 | 932 | ||
| 980 | (defun gnus-globalify-regexp (re) | 933 | (defun gnus-globalify-regexp (re) |
| 981 | "Returns a regexp that matches a whole line, iff RE matches a part of it." | 934 | "Returns a regexp that matches a whole line, iff RE matches a part of it." |
| @@ -983,6 +936,52 @@ ARG is passed to the first function." | |||
| 983 | re | 936 | re |
| 984 | (unless (string-match "\\$$" re) ".*$"))) | 937 | (unless (string-match "\\$$" re) ".*$"))) |
| 985 | 938 | ||
| 939 | (defun gnus-set-window-start (&optional point) | ||
| 940 | "Set the window start to POINT, or (point) if nil." | ||
| 941 | (let ((win (get-buffer-window (current-buffer) t))) | ||
| 942 | (when win | ||
| 943 | (set-window-start win (or point (point)))))) | ||
| 944 | |||
| 945 | (defun gnus-annotation-in-region-p (b e) | ||
| 946 | (if (= b e) | ||
| 947 | (eq (cadr (memq 'gnus-undeletable (text-properties-at b))) t) | ||
| 948 | (text-property-any b e 'gnus-undeletable t))) | ||
| 949 | |||
| 950 | (defun gnus-or (&rest elems) | ||
| 951 | "Return non-nil if any of the elements are non-nil." | ||
| 952 | (catch 'found | ||
| 953 | (while elems | ||
| 954 | (when (pop elems) | ||
| 955 | (throw 'found t))))) | ||
| 956 | |||
| 957 | (defun gnus-and (&rest elems) | ||
| 958 | "Return non-nil if all of the elements are non-nil." | ||
| 959 | (catch 'found | ||
| 960 | (while elems | ||
| 961 | (unless (pop elems) | ||
| 962 | (throw 'found nil))) | ||
| 963 | t)) | ||
| 964 | |||
| 965 | (defun gnus-write-active-file (file hashtb &optional full-names) | ||
| 966 | (let ((coding-system-for-write nnmail-active-file-coding-system)) | ||
| 967 | (with-temp-file file | ||
| 968 | (mapatoms | ||
| 969 | (lambda (sym) | ||
| 970 | (when (and sym | ||
| 971 | (boundp sym) | ||
| 972 | (symbol-value sym)) | ||
| 973 | (insert (format "%S %d %d y\n" | ||
| 974 | (if full-names | ||
| 975 | sym | ||
| 976 | (intern (gnus-group-real-name (symbol-name sym)))) | ||
| 977 | (or (cdr (symbol-value sym)) | ||
| 978 | (car (symbol-value sym))) | ||
| 979 | (car (symbol-value sym)))))) | ||
| 980 | hashtb) | ||
| 981 | (goto-char (point-max)) | ||
| 982 | (while (search-backward "\\." nil t) | ||
| 983 | (delete-char 1))))) | ||
| 984 | |||
| 986 | (provide 'gnus-util) | 985 | (provide 'gnus-util) |
| 987 | 986 | ||
| 988 | ;;; gnus-util.el ends here | 987 | ;;; gnus-util.el ends here |
diff --git a/lisp/gnus/nnheader.el b/lisp/gnus/nnheader.el index 395a2085e00..848d7e47a7a 100644 --- a/lisp/gnus/nnheader.el +++ b/lisp/gnus/nnheader.el | |||
| @@ -1,5 +1,8 @@ | |||
| 1 | ;;; nnheader.el --- header access macros for Gnus and its backends | 1 | ;;; nnheader.el --- header access macros for Gnus and its backends |
| 2 | ;; Copyright (C) 1987,88,89,90,93,94,95,96,97,98 Free Software Foundation, Inc. | 2 | |
| 3 | ;; Copyright (C) 1987, 1988, 1989, 1990, 1993, 1994, 1995, 1996, | ||
| 4 | ;; 1997, 1998, 2000 | ||
| 5 | ;; Free Software Foundation, Inc. | ||
| 3 | 6 | ||
| 4 | ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> | 7 | ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> |
| 5 | ;; Lars Magne Ingebrigtsen <larsi@gnus.org> | 8 | ;; Lars Magne Ingebrigtsen <larsi@gnus.org> |
| @@ -24,24 +27,12 @@ | |||
| 24 | 27 | ||
| 25 | ;;; Commentary: | 28 | ;;; Commentary: |
| 26 | 29 | ||
| 27 | ;; These macros may look very much like the ones in GNUS 4.1. They | ||
| 28 | ;; are, in a way, but you should note that the indices they use have | ||
| 29 | ;; been changed from the internal GNUS format to the NOV format. The | ||
| 30 | ;; makes it possible to read headers from XOVER much faster. | ||
| 31 | ;; | ||
| 32 | ;; The format of a header is now: | ||
| 33 | ;; [number subject from date id references chars lines xref] | ||
| 34 | ;; | ||
| 35 | ;; (That last entry is defined as "misc" in the NOV format, but Gnus | ||
| 36 | ;; uses it for xrefs.) | ||
| 37 | |||
| 38 | ;;; Code: | 30 | ;;; Code: |
| 39 | 31 | ||
| 40 | (eval-when-compile (require 'cl)) | 32 | (eval-when-compile (require 'cl)) |
| 41 | 33 | ||
| 42 | (eval-when-compile (require 'cl)) | ||
| 43 | |||
| 44 | (require 'mail-utils) | 34 | (require 'mail-utils) |
| 35 | (require 'mm-util) | ||
| 45 | 36 | ||
| 46 | (defvar nnheader-max-head-length 4096 | 37 | (defvar nnheader-max-head-length 4096 |
| 47 | "*Max length of the head of articles.") | 38 | "*Max length of the head of articles.") |
| @@ -51,23 +42,32 @@ | |||
| 51 | 42 | ||
| 52 | (defvar nnheader-file-name-translation-alist nil | 43 | (defvar nnheader-file-name-translation-alist nil |
| 53 | "*Alist that says how to translate characters in file names. | 44 | "*Alist that says how to translate characters in file names. |
| 54 | For instance, if \":\" is illegal as a file character in file names | 45 | For instance, if \":\" is invalid as a file character in file names |
| 55 | on your system, you could say something like: | 46 | on your system, you could say something like: |
| 56 | 47 | ||
| 57 | \(setq nnheader-file-name-translation-alist '((?: . ?_)))") | 48 | \(setq nnheader-file-name-translation-alist '((?: . ?_)))") |
| 58 | 49 | ||
| 59 | (eval-and-compile | 50 | (eval-and-compile |
| 60 | (autoload 'nnmail-message-id "nnmail") | 51 | (autoload 'nnmail-message-id "nnmail") |
| 61 | (autoload 'mail-position-on-field "sendmail") | 52 | (autoload 'mail-position-on-field "sendmail") |
| 62 | (autoload 'message-remove-header "message") | 53 | (autoload 'message-remove-header "message") |
| 63 | (autoload 'cancel-function-timers "timers") | 54 | (autoload 'gnus-point-at-eol "gnus-util") |
| 64 | (autoload 'gnus-point-at-eol "gnus-util") | 55 | (autoload 'gnus-delete-line "gnus-util") |
| 65 | (autoload 'gnus-delete-line "gnus-util") | 56 | (autoload 'gnus-buffer-live-p "gnus-util")) |
| 66 | (autoload 'gnus-buffer-live-p "gnus-util") | ||
| 67 | (autoload 'gnus-encode-coding-string "gnus-ems")) | ||
| 68 | 57 | ||
| 69 | ;;; Header access macros. | 58 | ;;; Header access macros. |
| 70 | 59 | ||
| 60 | ;; These macros may look very much like the ones in GNUS 4.1. They | ||
| 61 | ;; are, in a way, but you should note that the indices they use have | ||
| 62 | ;; been changed from the internal GNUS format to the NOV format. The | ||
| 63 | ;; makes it possible to read headers from XOVER much faster. | ||
| 64 | ;; | ||
| 65 | ;; The format of a header is now: | ||
| 66 | ;; [number subject from date id references chars lines xref extra] | ||
| 67 | ;; | ||
| 68 | ;; (That next-to-last entry is defined as "misc" in the NOV format, | ||
| 69 | ;; but Gnus uses it for xrefs.) | ||
| 70 | |||
| 71 | (defmacro mail-header-number (header) | 71 | (defmacro mail-header-number (header) |
| 72 | "Return article number in HEADER." | 72 | "Return article number in HEADER." |
| 73 | `(aref ,header 0)) | 73 | `(aref ,header 0)) |
| @@ -139,17 +139,26 @@ on your system, you could say something like: | |||
| 139 | `(aref ,header 8)) | 139 | `(aref ,header 8)) |
| 140 | 140 | ||
| 141 | (defmacro mail-header-set-xref (header xref) | 141 | (defmacro mail-header-set-xref (header xref) |
| 142 | "Set article xref of HEADER to xref." | 142 | "Set article XREF of HEADER to xref." |
| 143 | `(aset ,header 8 ,xref)) | 143 | `(aset ,header 8 ,xref)) |
| 144 | 144 | ||
| 145 | (defun make-mail-header (&optional init) | 145 | (defmacro mail-header-extra (header) |
| 146 | "Return the extra headers in HEADER." | ||
| 147 | `(aref ,header 9)) | ||
| 148 | |||
| 149 | (defmacro mail-header-set-extra (header extra) | ||
| 150 | "Set the extra headers in HEADER to EXTRA." | ||
| 151 | `(aset ,header 9 ',extra)) | ||
| 152 | |||
| 153 | (defsubst make-mail-header (&optional init) | ||
| 146 | "Create a new mail header structure initialized with INIT." | 154 | "Create a new mail header structure initialized with INIT." |
| 147 | (make-vector 9 init)) | 155 | (make-vector 10 init)) |
| 148 | 156 | ||
| 149 | (defun make-full-mail-header (&optional number subject from date id | 157 | (defsubst make-full-mail-header (&optional number subject from date id |
| 150 | references chars lines xref) | 158 | references chars lines xref |
| 159 | extra) | ||
| 151 | "Create a new mail header structure initialized with the parameters given." | 160 | "Create a new mail header structure initialized with the parameters given." |
| 152 | (vector number subject from date id references chars lines xref)) | 161 | (vector number subject from date id references chars lines xref extra)) |
| 153 | 162 | ||
| 154 | ;; fake message-ids: generation and detection | 163 | ;; fake message-ids: generation and detection |
| 155 | 164 | ||
| @@ -235,11 +244,12 @@ on your system, you could say something like: | |||
| 235 | ;; promising. | 244 | ;; promising. |
| 236 | (if (and (search-forward "\nin-reply-to: " nil t) | 245 | (if (and (search-forward "\nin-reply-to: " nil t) |
| 237 | (setq in-reply-to (nnheader-header-value)) | 246 | (setq in-reply-to (nnheader-header-value)) |
| 238 | (string-match "<[^>]+>" in-reply-to)) | 247 | (string-match "<[^\n>]+>" in-reply-to)) |
| 239 | (let (ref2) | 248 | (let (ref2) |
| 240 | (setq ref (substring in-reply-to (match-beginning 0) | 249 | (setq ref (substring in-reply-to (match-beginning 0) |
| 241 | (match-end 0))) | 250 | (match-end 0))) |
| 242 | (while (string-match "<[^>]+>" in-reply-to (match-end 0)) | 251 | (while (string-match "<[^\n>]+>" |
| 252 | in-reply-to (match-end 0)) | ||
| 243 | (setq ref2 (substring in-reply-to (match-beginning 0) | 253 | (setq ref2 (substring in-reply-to (match-beginning 0) |
| 244 | (match-end 0))) | 254 | (match-end 0))) |
| 245 | (when (> (length ref2) (length ref)) | 255 | (when (> (length ref2) (length ref)) |
| @@ -259,7 +269,20 @@ on your system, you could say something like: | |||
| 259 | (progn | 269 | (progn |
| 260 | (goto-char p) | 270 | (goto-char p) |
| 261 | (and (search-forward "\nxref: " nil t) | 271 | (and (search-forward "\nxref: " nil t) |
| 262 | (nnheader-header-value))))) | 272 | (nnheader-header-value))) |
| 273 | |||
| 274 | ;; Extra. | ||
| 275 | (when nnmail-extra-headers | ||
| 276 | (let ((extra nnmail-extra-headers) | ||
| 277 | out) | ||
| 278 | (while extra | ||
| 279 | (goto-char p) | ||
| 280 | (when (search-forward | ||
| 281 | (concat "\n" (symbol-name (car extra)) ": ") nil t) | ||
| 282 | (push (cons (car extra) (nnheader-header-value)) | ||
| 283 | out)) | ||
| 284 | (pop extra)) | ||
| 285 | out)))) | ||
| 263 | (when naked | 286 | (when naked |
| 264 | (goto-char (point-min)) | 287 | (goto-char (point-min)) |
| 265 | (delete-char 1))))) | 288 | (delete-char 1))))) |
| @@ -272,13 +295,29 @@ on your system, you could say something like: | |||
| 272 | 295 | ||
| 273 | (defmacro nnheader-nov-read-integer () | 296 | (defmacro nnheader-nov-read-integer () |
| 274 | '(prog1 | 297 | '(prog1 |
| 275 | (if (= (following-char) ?\t) | 298 | (if (eq (char-after) ?\t) |
| 276 | 0 | 299 | 0 |
| 277 | (let ((num (ignore-errors (read (current-buffer))))) | 300 | (let ((num (condition-case nil |
| 301 | (read (current-buffer)) | ||
| 302 | (error nil)))) | ||
| 278 | (if (numberp num) num 0))) | 303 | (if (numberp num) num 0))) |
| 279 | (or (eobp) (forward-char 1)))) | 304 | (or (eobp) (forward-char 1)))) |
| 280 | 305 | ||
| 281 | ;; (defvar nnheader-none-counter 0) | 306 | (defmacro nnheader-nov-parse-extra () |
| 307 | '(let (out string) | ||
| 308 | (while (not (memq (char-after) '(?\n nil))) | ||
| 309 | (setq string (nnheader-nov-field)) | ||
| 310 | (when (string-match "^\\([^ :]+\\): " string) | ||
| 311 | (push (cons (intern (match-string 1 string)) | ||
| 312 | (substring string (match-end 0))) | ||
| 313 | out))) | ||
| 314 | out)) | ||
| 315 | |||
| 316 | (defmacro nnheader-nov-read-message-id () | ||
| 317 | '(let ((id (nnheader-nov-field))) | ||
| 318 | (if (string-match "^<[^>]+>$" id) | ||
| 319 | id | ||
| 320 | (nnheader-generate-fake-message-id)))) | ||
| 282 | 321 | ||
| 283 | (defun nnheader-parse-nov () | 322 | (defun nnheader-parse-nov () |
| 284 | (let ((eol (gnus-point-at-eol))) | 323 | (let ((eol (gnus-point-at-eol))) |
| @@ -287,34 +326,60 @@ on your system, you could say something like: | |||
| 287 | (nnheader-nov-field) ; subject | 326 | (nnheader-nov-field) ; subject |
| 288 | (nnheader-nov-field) ; from | 327 | (nnheader-nov-field) ; from |
| 289 | (nnheader-nov-field) ; date | 328 | (nnheader-nov-field) ; date |
| 290 | (or (nnheader-nov-field) | 329 | (nnheader-nov-read-message-id) ; id |
| 291 | (nnheader-generate-fake-message-id)) ; id | ||
| 292 | (nnheader-nov-field) ; refs | 330 | (nnheader-nov-field) ; refs |
| 293 | (nnheader-nov-read-integer) ; chars | 331 | (nnheader-nov-read-integer) ; chars |
| 294 | (nnheader-nov-read-integer) ; lines | 332 | (nnheader-nov-read-integer) ; lines |
| 295 | (if (= (following-char) ?\n) | 333 | (if (eq (char-after) ?\n) |
| 296 | nil | 334 | nil |
| 297 | (nnheader-nov-field)) ; misc | 335 | (if (looking-at "Xref: ") |
| 298 | ))) | 336 | (goto-char (match-end 0))) |
| 337 | (nnheader-nov-field)) ; Xref | ||
| 338 | (nnheader-nov-parse-extra)))) ; extra | ||
| 299 | 339 | ||
| 300 | (defun nnheader-insert-nov (header) | 340 | (defun nnheader-insert-nov (header) |
| 301 | (princ (mail-header-number header) (current-buffer)) | 341 | (princ (mail-header-number header) (current-buffer)) |
| 342 | (let ((p (point))) | ||
| 343 | (insert | ||
| 344 | "\t" | ||
| 345 | (or (mail-header-subject header) "(none)") "\t" | ||
| 346 | (or (mail-header-from header) "(nobody)") "\t" | ||
| 347 | (or (mail-header-date header) "") "\t" | ||
| 348 | (or (mail-header-id header) | ||
| 349 | (nnmail-message-id)) | ||
| 350 | "\t" | ||
| 351 | (or (mail-header-references header) "") "\t") | ||
| 352 | (princ (or (mail-header-chars header) 0) (current-buffer)) | ||
| 353 | (insert "\t") | ||
| 354 | (princ (or (mail-header-lines header) 0) (current-buffer)) | ||
| 355 | (insert "\t") | ||
| 356 | (when (mail-header-xref header) | ||
| 357 | (insert "Xref: " (mail-header-xref header))) | ||
| 358 | (when (or (mail-header-xref header) | ||
| 359 | (mail-header-extra header)) | ||
| 360 | (insert "\t")) | ||
| 361 | (when (mail-header-extra header) | ||
| 362 | (let ((extra (mail-header-extra header))) | ||
| 363 | (while extra | ||
| 364 | (insert (symbol-name (caar extra)) | ||
| 365 | ": " (cdar extra) "\t") | ||
| 366 | (pop extra)))) | ||
| 367 | (insert "\n") | ||
| 368 | (backward-char 1) | ||
| 369 | (while (search-backward "\n" p t) | ||
| 370 | (delete-char 1)) | ||
| 371 | (forward-line 1))) | ||
| 372 | |||
| 373 | (defun nnheader-insert-header (header) | ||
| 302 | (insert | 374 | (insert |
| 303 | "\t" | 375 | "Subject: " (or (mail-header-subject header) "(none)") "\n" |
| 304 | (or (mail-header-subject header) "(none)") "\t" | 376 | "From: " (or (mail-header-from header) "(nobody)") "\n" |
| 305 | (or (mail-header-from header) "(nobody)") "\t" | 377 | "Date: " (or (mail-header-date header) "") "\n" |
| 306 | (or (mail-header-date header) "") "\t" | 378 | "Message-ID: " (or (mail-header-id header) (nnmail-message-id)) "\n" |
| 307 | (or (mail-header-id header) | 379 | "References: " (or (mail-header-references header) "") "\n" |
| 308 | (nnmail-message-id)) | 380 | "Lines: ") |
| 309 | "\t" | ||
| 310 | (or (mail-header-references header) "") "\t") | ||
| 311 | (princ (or (mail-header-chars header) 0) (current-buffer)) | ||
| 312 | (insert "\t") | ||
| 313 | (princ (or (mail-header-lines header) 0) (current-buffer)) | 381 | (princ (or (mail-header-lines header) 0) (current-buffer)) |
| 314 | (insert "\t") | 382 | (insert "\n\n")) |
| 315 | (when (mail-header-xref header) | ||
| 316 | (insert "Xref: " (mail-header-xref header) "\t")) | ||
| 317 | (insert "\n")) | ||
| 318 | 383 | ||
| 319 | (defun nnheader-insert-article-line (article) | 384 | (defun nnheader-insert-article-line (article) |
| 320 | (goto-char (point-min)) | 385 | (goto-char (point-min)) |
| @@ -401,6 +466,7 @@ the line could be found." | |||
| 401 | (save-excursion | 466 | (save-excursion |
| 402 | (unless (gnus-buffer-live-p nntp-server-buffer) | 467 | (unless (gnus-buffer-live-p nntp-server-buffer) |
| 403 | (setq nntp-server-buffer (get-buffer-create " *nntpd*"))) | 468 | (setq nntp-server-buffer (get-buffer-create " *nntpd*"))) |
| 469 | (mm-enable-multibyte) | ||
| 404 | (set-buffer nntp-server-buffer) | 470 | (set-buffer nntp-server-buffer) |
| 405 | (erase-buffer) | 471 | (erase-buffer) |
| 406 | (kill-all-local-variables) | 472 | (kill-all-local-variables) |
| @@ -447,7 +513,7 @@ the line could be found." | |||
| 447 | nil | 513 | nil |
| 448 | (narrow-to-region (point-min) (1- (point))) | 514 | (narrow-to-region (point-min) (1- (point))) |
| 449 | (goto-char (point-min)) | 515 | (goto-char (point-min)) |
| 450 | (while (looking-at "[A-Z][^ \t]+:.*\n\\([ \t].*\n\\)*\\|From .*\n") | 516 | (while (looking-at "[a-zA-Z][^ \t]+:.*\n\\([ \t].*\n\\)*\\|From .*\n") |
| 451 | (goto-char (match-end 0))) | 517 | (goto-char (match-end 0))) |
| 452 | (prog1 | 518 | (prog1 |
| 453 | (eobp) | 519 | (eobp) |
| @@ -456,7 +522,8 @@ the line could be found." | |||
| 456 | (defun nnheader-insert-references (references message-id) | 522 | (defun nnheader-insert-references (references message-id) |
| 457 | "Insert a References header based on REFERENCES and MESSAGE-ID." | 523 | "Insert a References header based on REFERENCES and MESSAGE-ID." |
| 458 | (if (and (not references) (not message-id)) | 524 | (if (and (not references) (not message-id)) |
| 459 | () ; This is illegal, but not all articles have Message-IDs. | 525 | ;; This is invalid, but not all articles have Message-IDs. |
| 526 | () | ||
| 460 | (mail-position-on-field "References") | 527 | (mail-position-on-field "References") |
| 461 | (let ((begin (save-excursion (beginning-of-line) (point))) | 528 | (let ((begin (save-excursion (beginning-of-line) (point))) |
| 462 | (fill-column 78) | 529 | (fill-column 78) |
| @@ -495,58 +562,12 @@ the line could be found." | |||
| 495 | (defun nnheader-set-temp-buffer (name &optional noerase) | 562 | (defun nnheader-set-temp-buffer (name &optional noerase) |
| 496 | "Set-buffer to an empty (possibly new) buffer called NAME with undo disabled." | 563 | "Set-buffer to an empty (possibly new) buffer called NAME with undo disabled." |
| 497 | (set-buffer (get-buffer-create name)) | 564 | (set-buffer (get-buffer-create name)) |
| 498 | (buffer-disable-undo (current-buffer)) | 565 | (buffer-disable-undo) |
| 499 | (unless noerase | 566 | (unless noerase |
| 500 | (erase-buffer)) | 567 | (erase-buffer)) |
| 501 | (current-buffer)) | 568 | (current-buffer)) |
| 502 | 569 | ||
| 503 | (defmacro nnheader-temp-write (file &rest forms) | 570 | (eval-when-compile (defvar jka-compr-compression-info-list)) |
| 504 | "Create a new buffer, evaluate FORMS there, and write the buffer to FILE. | ||
| 505 | Return the value of FORMS. | ||
| 506 | If FILE is nil, just evaluate FORMS and don't save anything. | ||
| 507 | If FILE is t, return the buffer contents as a string." | ||
| 508 | (let ((temp-file (make-symbol "temp-file")) | ||
| 509 | (temp-buffer (make-symbol "temp-buffer")) | ||
| 510 | (temp-results (make-symbol "temp-results"))) | ||
| 511 | `(save-excursion | ||
| 512 | (let* ((,temp-file ,file) | ||
| 513 | (default-major-mode 'fundamental-mode) | ||
| 514 | (,temp-buffer | ||
| 515 | (set-buffer | ||
| 516 | (get-buffer-create | ||
| 517 | (generate-new-buffer-name " *nnheader temp*")))) | ||
| 518 | ,temp-results) | ||
| 519 | (unwind-protect | ||
| 520 | (progn | ||
| 521 | (setq ,temp-results (progn ,@forms)) | ||
| 522 | (cond | ||
| 523 | ;; Don't save anything. | ||
| 524 | ((null ,temp-file) | ||
| 525 | ,temp-results) | ||
| 526 | ;; Return the buffer contents. | ||
| 527 | ((eq ,temp-file t) | ||
| 528 | (set-buffer ,temp-buffer) | ||
| 529 | (buffer-string)) | ||
| 530 | ;; Save a file. | ||
| 531 | (t | ||
| 532 | (set-buffer ,temp-buffer) | ||
| 533 | ;; Make sure the directory where this file is | ||
| 534 | ;; to be saved exists. | ||
| 535 | (when (not (file-directory-p | ||
| 536 | (file-name-directory ,temp-file))) | ||
| 537 | (make-directory (file-name-directory ,temp-file) t)) | ||
| 538 | ;; Save the file. | ||
| 539 | (write-region (point-min) (point-max) | ||
| 540 | ,temp-file nil 'nomesg) | ||
| 541 | ,temp-results))) | ||
| 542 | ;; Kill the buffer. | ||
| 543 | (when (buffer-name ,temp-buffer) | ||
| 544 | (kill-buffer ,temp-buffer))))))) | ||
| 545 | |||
| 546 | (put 'nnheader-temp-write 'lisp-indent-function 1) | ||
| 547 | (put 'nnheader-temp-write 'edebug-form-spec '(form body)) | ||
| 548 | |||
| 549 | (defvar jka-compr-compression-info-list) | ||
| 550 | (defvar nnheader-numerical-files | 571 | (defvar nnheader-numerical-files |
| 551 | (if (boundp 'jka-compr-compression-info-list) | 572 | (if (boundp 'jka-compr-compression-info-list) |
| 552 | (concat "\\([0-9]+\\)\\(" | 573 | (concat "\\([0-9]+\\)\\(" |
| @@ -563,7 +584,7 @@ If FILE is t, return the buffer contents as a string." | |||
| 563 | "Regexp that matches numerical full file paths.") | 584 | "Regexp that matches numerical full file paths.") |
| 564 | 585 | ||
| 565 | (defsubst nnheader-file-to-number (file) | 586 | (defsubst nnheader-file-to-number (file) |
| 566 | "Take a file name and return the article number." | 587 | "Take a FILE name and return the article number." |
| 567 | (if (string= nnheader-numerical-short-files "^[0-9]+$") | 588 | (if (string= nnheader-numerical-short-files "^[0-9]+$") |
| 568 | (string-to-int file) | 589 | (string-to-int file) |
| 569 | (string-match nnheader-numerical-short-files file) | 590 | (string-match nnheader-numerical-short-files file) |
| @@ -581,7 +602,7 @@ If FILE is t, return the buffer contents as a string." | |||
| 581 | second))) | 602 | second))) |
| 582 | 603 | ||
| 583 | (defun nnheader-directory-articles (dir) | 604 | (defun nnheader-directory-articles (dir) |
| 584 | "Return a list of all article files in a directory." | 605 | "Return a list of all article files in directory DIR." |
| 585 | (mapcar 'nnheader-file-to-number | 606 | (mapcar 'nnheader-file-to-number |
| 586 | (nnheader-directory-files-safe | 607 | (nnheader-directory-files-safe |
| 587 | dir nil nnheader-numerical-short-files t))) | 608 | dir nil nnheader-numerical-short-files t))) |
| @@ -607,7 +628,9 @@ If FULL, translate everything." | |||
| 607 | (if full | 628 | (if full |
| 608 | ;; Do complete translation. | 629 | ;; Do complete translation. |
| 609 | (setq leaf (copy-sequence file) | 630 | (setq leaf (copy-sequence file) |
| 610 | path "") | 631 | path "" |
| 632 | i (if (and (< 1 (length leaf)) (eq ?: (aref leaf 1))) | ||
| 633 | 2 0)) | ||
| 611 | ;; We translate -- but only the file name. We leave the directory | 634 | ;; We translate -- but only the file name. We leave the directory |
| 612 | ;; alone. | 635 | ;; alone. |
| 613 | (if (string-match "/[^/]+\\'" file) | 636 | (if (string-match "/[^/]+\\'" file) |
| @@ -638,7 +661,7 @@ The first string in ARGS can be a format string." | |||
| 638 | "Get the most recent report from BACKEND." | 661 | "Get the most recent report from BACKEND." |
| 639 | (condition-case () | 662 | (condition-case () |
| 640 | (nnheader-message 5 "%s" (symbol-value (intern (format "%s-status-string" | 663 | (nnheader-message 5 "%s" (symbol-value (intern (format "%s-status-string" |
| 641 | backend)))) | 664 | backend)))) |
| 642 | (error (nnheader-message 5 "")))) | 665 | (error (nnheader-message 5 "")))) |
| 643 | 666 | ||
| 644 | (defun nnheader-insert (format &rest args) | 667 | (defun nnheader-insert (format &rest args) |
| @@ -653,15 +676,33 @@ without formatting." | |||
| 653 | (apply 'insert format args)) | 676 | (apply 'insert format args)) |
| 654 | t)) | 677 | t)) |
| 655 | 678 | ||
| 656 | (defun nnheader-replace-chars-in-string (string from to) | 679 | (if (fboundp 'subst-char-in-string) |
| 680 | (defsubst nnheader-replace-chars-in-string (string from to) | ||
| 681 | (subst-char-in-string from to string)) | ||
| 682 | (defun nnheader-replace-chars-in-string (string from to) | ||
| 683 | "Replace characters in STRING from FROM to TO." | ||
| 684 | (let ((string (substring string 0)) ;Copy string. | ||
| 685 | (len (length string)) | ||
| 686 | (idx 0)) | ||
| 687 | ;; Replace all occurrences of FROM with TO. | ||
| 688 | (while (< idx len) | ||
| 689 | (when (= (aref string idx) from) | ||
| 690 | (aset string idx to)) | ||
| 691 | (setq idx (1+ idx))) | ||
| 692 | string))) | ||
| 693 | |||
| 694 | (defun nnheader-replace-duplicate-chars-in-string (string from to) | ||
| 657 | "Replace characters in STRING from FROM to TO." | 695 | "Replace characters in STRING from FROM to TO." |
| 658 | (let ((string (substring string 0)) ;Copy string. | 696 | (let ((string (substring string 0)) ;Copy string. |
| 659 | (len (length string)) | 697 | (len (length string)) |
| 660 | (idx 0)) | 698 | (idx 0) prev i) |
| 661 | ;; Replace all occurrences of FROM with TO. | 699 | ;; Replace all occurrences of FROM with TO. |
| 662 | (while (< idx len) | 700 | (while (< idx len) |
| 663 | (when (= (aref string idx) from) | 701 | (setq i (aref string idx)) |
| 702 | (when (and (eq prev from) (= i from)) | ||
| 703 | (aset string (1- idx) to) | ||
| 664 | (aset string idx to)) | 704 | (aset string idx to)) |
| 705 | (setq prev i) | ||
| 665 | (setq idx (1+ idx))) | 706 | (setq idx (1+ idx))) |
| 666 | string)) | 707 | string)) |
| 667 | 708 | ||
| @@ -690,12 +731,7 @@ without formatting." | |||
| 690 | (or (not (numberp gnus-verbose-backends)) | 731 | (or (not (numberp gnus-verbose-backends)) |
| 691 | (<= level gnus-verbose-backends))) | 732 | (<= level gnus-verbose-backends))) |
| 692 | 733 | ||
| 693 | (defvar nnheader-pathname-coding-system 'iso-8859-1 | 734 | (defvar nnheader-pathname-coding-system 'binary |
| 694 | "*Coding system for pathname.") | ||
| 695 | |||
| 696 | ;; 1997/8/10 by MORIOKA Tomohiko | ||
| 697 | (defvar nnheader-pathname-coding-system | ||
| 698 | 'iso-8859-1 | ||
| 699 | "*Coding system for pathname.") | 735 | "*Coding system for pathname.") |
| 700 | 736 | ||
| 701 | (defun nnheader-group-pathname (group dir &optional file) | 737 | (defun nnheader-group-pathname (group dir &optional file) |
| @@ -703,14 +739,14 @@ without formatting." | |||
| 703 | (concat | 739 | (concat |
| 704 | (let ((dir (file-name-as-directory (expand-file-name dir)))) | 740 | (let ((dir (file-name-as-directory (expand-file-name dir)))) |
| 705 | ;; If this directory exists, we use it directly. | 741 | ;; If this directory exists, we use it directly. |
| 706 | (if (file-directory-p (concat dir group)) | 742 | (file-name-as-directory |
| 707 | (concat dir group "/") | 743 | (if (file-directory-p (concat dir group)) |
| 708 | ;; If not, we translate dots into slashes. | 744 | (expand-file-name group dir) |
| 709 | (concat dir | 745 | ;; If not, we translate dots into slashes. |
| 710 | (gnus-encode-coding-string | 746 | (expand-file-name (mm-encode-coding-string |
| 711 | (nnheader-replace-chars-in-string group ?. ?/) | 747 | (nnheader-replace-chars-in-string group ?. ?/) |
| 712 | nnheader-pathname-coding-system) | 748 | nnheader-pathname-coding-system) |
| 713 | "/"))) | 749 | dir)))) |
| 714 | (cond ((null file) "") | 750 | (cond ((null file) "") |
| 715 | ((numberp file) (int-to-string file)) | 751 | ((numberp file) (int-to-string file)) |
| 716 | (t file)))) | 752 | (t file)))) |
| @@ -721,7 +757,7 @@ without formatting." | |||
| 721 | (and (listp form) (eq (car form) 'lambda)))) | 757 | (and (listp form) (eq (car form) 'lambda)))) |
| 722 | 758 | ||
| 723 | (defun nnheader-concat (dir &rest files) | 759 | (defun nnheader-concat (dir &rest files) |
| 724 | "Concat DIR as directory to FILE." | 760 | "Concat DIR as directory to FILES." |
| 725 | (apply 'concat (file-name-as-directory dir) files)) | 761 | (apply 'concat (file-name-as-directory dir) files)) |
| 726 | 762 | ||
| 727 | (defun nnheader-ms-strip-cr () | 763 | (defun nnheader-ms-strip-cr () |
| @@ -770,45 +806,26 @@ If FILE, find the \".../etc/PACKAGE\" file instead." | |||
| 770 | (defvar nnheader-file-coding-system 'raw-text | 806 | (defvar nnheader-file-coding-system 'raw-text |
| 771 | "Coding system used in file backends of Gnus.") | 807 | "Coding system used in file backends of Gnus.") |
| 772 | 808 | ||
| 773 | ;; 1997/5/4 by MORIOKA Tomohiko <morioka@jaist.ac.jp> | ||
| 774 | (defvar nnheader-file-coding-system nil | ||
| 775 | "Coding system used in file backends of Gnus.") | ||
| 776 | |||
| 777 | (defun nnheader-insert-file-contents (filename &optional visit beg end replace) | 809 | (defun nnheader-insert-file-contents (filename &optional visit beg end replace) |
| 778 | "Like `insert-file-contents', q.v., but only reads in the file. | 810 | "Like `insert-file-contents', q.v., but only reads in the file. |
| 779 | A buffer may be modified in several ways after reading into the buffer due | 811 | A buffer may be modified in several ways after reading into the buffer due |
| 780 | to advanced Emacs features, such as file-name-handlers, format decoding, | 812 | to advanced Emacs features, such as file-name-handlers, format decoding, |
| 781 | find-file-hooks, etc. | 813 | find-file-hooks, etc. |
| 782 | This function ensures that none of these modifications will take place." | 814 | This function ensures that none of these modifications will take place." |
| 783 | (let ((format-alist nil) | 815 | (let ((coding-system-for-read nnheader-file-coding-system)) |
| 784 | (auto-mode-alist (nnheader-auto-mode-alist)) | 816 | (mm-insert-file-contents filename visit beg end replace))) |
| 785 | (default-major-mode 'fundamental-mode) | ||
| 786 | (enable-local-variables nil) | ||
| 787 | (after-insert-file-functions nil) | ||
| 788 | (find-file-hooks nil) | ||
| 789 | (coding-system-for-read nnheader-file-coding-system)) | ||
| 790 | (insert-file-contents filename visit beg end replace))) | ||
| 791 | 817 | ||
| 792 | (defun nnheader-find-file-noselect (&rest args) | 818 | (defun nnheader-find-file-noselect (&rest args) |
| 793 | (let ((format-alist nil) | 819 | (let ((format-alist nil) |
| 794 | (auto-mode-alist (nnheader-auto-mode-alist)) | 820 | (auto-mode-alist (mm-auto-mode-alist)) |
| 795 | (default-major-mode 'fundamental-mode) | 821 | (default-major-mode 'fundamental-mode) |
| 796 | (enable-local-variables nil) | 822 | (enable-local-variables nil) |
| 797 | (after-insert-file-functions nil) | 823 | (after-insert-file-functions nil) |
| 824 | (enable-local-eval nil) | ||
| 798 | (find-file-hooks nil) | 825 | (find-file-hooks nil) |
| 799 | (coding-system-for-read nnheader-file-coding-system)) | 826 | (coding-system-for-read nnheader-file-coding-system)) |
| 800 | (apply 'find-file-noselect args))) | 827 | (apply 'find-file-noselect args))) |
| 801 | 828 | ||
| 802 | (defun nnheader-auto-mode-alist () | ||
| 803 | "Return an `auto-mode-alist' with only the .gz (etc) thingies." | ||
| 804 | (let ((alist auto-mode-alist) | ||
| 805 | out) | ||
| 806 | (while alist | ||
| 807 | (when (listp (cdar alist)) | ||
| 808 | (push (car alist) out)) | ||
| 809 | (pop alist)) | ||
| 810 | (nreverse out))) | ||
| 811 | |||
| 812 | (defun nnheader-directory-regular-files (dir) | 829 | (defun nnheader-directory-regular-files (dir) |
| 813 | "Return a list of all regular files in DIR." | 830 | "Return a list of all regular files in DIR." |
| 814 | (let ((files (directory-files dir t)) | 831 | (let ((files (directory-files dir t)) |
| @@ -833,8 +850,6 @@ find-file-hooks, etc. | |||
| 833 | `(let ((new (generate-new-buffer " *nnheader replace*")) | 850 | `(let ((new (generate-new-buffer " *nnheader replace*")) |
| 834 | (cur (current-buffer)) | 851 | (cur (current-buffer)) |
| 835 | (start (point-min))) | 852 | (start (point-min))) |
| 836 | (set-buffer new) | ||
| 837 | (buffer-disable-undo (current-buffer)) | ||
| 838 | (set-buffer cur) | 853 | (set-buffer cur) |
| 839 | (goto-char (point-min)) | 854 | (goto-char (point-min)) |
| 840 | (while (,(if regexp 're-search-forward 'search-forward) | 855 | (while (,(if regexp 're-search-forward 'search-forward) |
| @@ -852,22 +867,22 @@ find-file-hooks, etc. | |||
| 852 | (set-buffer cur))) | 867 | (set-buffer cur))) |
| 853 | 868 | ||
| 854 | (defun nnheader-replace-string (from to) | 869 | (defun nnheader-replace-string (from to) |
| 855 | "Do a fast replacement of FROM to TO from point to point-max." | 870 | "Do a fast replacement of FROM to TO from point to `point-max'." |
| 856 | (nnheader-skeleton-replace from to)) | 871 | (nnheader-skeleton-replace from to)) |
| 857 | 872 | ||
| 858 | (defun nnheader-replace-regexp (from to) | 873 | (defun nnheader-replace-regexp (from to) |
| 859 | "Do a fast regexp replacement of FROM to TO from point to point-max." | 874 | "Do a fast regexp replacement of FROM to TO from point to `point-max'." |
| 860 | (nnheader-skeleton-replace from to t)) | 875 | (nnheader-skeleton-replace from to t)) |
| 861 | 876 | ||
| 862 | (defun nnheader-strip-cr () | 877 | (defun nnheader-strip-cr () |
| 863 | "Strip all \r's from the current buffer." | 878 | "Strip all \r's from the current buffer." |
| 864 | (nnheader-skeleton-replace "\r")) | 879 | (nnheader-skeleton-replace "\r")) |
| 865 | 880 | ||
| 866 | (fset 'nnheader-run-at-time 'run-at-time) | 881 | (defalias 'nnheader-run-at-time 'run-at-time) |
| 867 | (fset 'nnheader-cancel-timer 'cancel-timer) | 882 | (defalias 'nnheader-cancel-timer 'cancel-timer) |
| 868 | (fset 'nnheader-cancel-function-timers 'cancel-function-timers) | 883 | (defalias 'nnheader-cancel-function-timers 'cancel-function-timers) |
| 869 | 884 | ||
| 870 | (when (string-match "XEmacs\\|Lucid" emacs-version) | 885 | (when (string-match "XEmacs" emacs-version) |
| 871 | (require 'nnheaderxm)) | 886 | (require 'nnheaderxm)) |
| 872 | 887 | ||
| 873 | (run-hooks 'nnheader-load-hook) | 888 | (run-hooks 'nnheader-load-hook) |
diff --git a/lisp/gnus/nnkiboze.el b/lisp/gnus/nnkiboze.el index c47a10d3911..d93800a5b97 100644 --- a/lisp/gnus/nnkiboze.el +++ b/lisp/gnus/nnkiboze.el | |||
| @@ -1,5 +1,7 @@ | |||
| 1 | ;;; nnkiboze.el --- select virtual news access for Gnus | 1 | ;;; nnkiboze.el --- select virtual news access for Gnus |
| 2 | ;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. | 2 | |
| 3 | ;; Copyright (C) 1995, 1996, 1997, 1998, 1999,.2000 | ||
| 4 | ;; Free Software Foundation, Inc. | ||
| 3 | 5 | ||
| 4 | ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> | 6 | ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
| 5 | ;; Keywords: news | 7 | ;; Keywords: news |
| @@ -34,6 +36,7 @@ | |||
| 34 | (require 'gnus) | 36 | (require 'gnus) |
| 35 | (require 'gnus-score) | 37 | (require 'gnus-score) |
| 36 | (require 'nnoo) | 38 | (require 'nnoo) |
| 39 | (require 'mm-util) | ||
| 37 | (eval-when-compile (require 'cl)) | 40 | (eval-when-compile (require 'cl)) |
| 38 | 41 | ||
| 39 | (nnoo-declare nnkiboze) | 42 | (nnoo-declare nnkiboze) |
| @@ -55,6 +58,9 @@ | |||
| 55 | (defvoo nnkiboze-regexp nil | 58 | (defvoo nnkiboze-regexp nil |
| 56 | "Regexp for matching component groups.") | 59 | "Regexp for matching component groups.") |
| 57 | 60 | ||
| 61 | (defvoo nnkiboze-file-coding-system mm-text-coding-system | ||
| 62 | "Coding system for nnkiboze files.") | ||
| 63 | |||
| 58 | 64 | ||
| 59 | 65 | ||
| 60 | (defconst nnkiboze-version "nnkiboze 1.0") | 66 | (defconst nnkiboze-version "nnkiboze 1.0") |
| @@ -80,7 +86,8 @@ | |||
| 80 | (save-excursion | 86 | (save-excursion |
| 81 | (set-buffer nntp-server-buffer) | 87 | (set-buffer nntp-server-buffer) |
| 82 | (erase-buffer) | 88 | (erase-buffer) |
| 83 | (nnheader-insert-file-contents nov) | 89 | (let ((nnheader-file-coding-system nnkiboze-file-coding-system)) |
| 90 | (nnheader-insert-file-contents nov)) | ||
| 84 | (nnheader-nov-delete-outside-range | 91 | (nnheader-nov-delete-outside-range |
| 85 | (car articles) (car (last articles))) | 92 | (car articles) (car (last articles))) |
| 86 | 'nov)))))) | 93 | 'nov)))))) |
| @@ -119,7 +126,8 @@ | |||
| 119 | (nnkiboze-request-scan group)) | 126 | (nnkiboze-request-scan group)) |
| 120 | (if (not (file-exists-p nov-file)) | 127 | (if (not (file-exists-p nov-file)) |
| 121 | (nnheader-report 'nnkiboze "Can't select group %s" group) | 128 | (nnheader-report 'nnkiboze "Can't select group %s" group) |
| 122 | (nnheader-insert-file-contents nov-file) | 129 | (let ((nnheader-file-coding-system nnkiboze-file-coding-system)) |
| 130 | (nnheader-insert-file-contents nov-file)) | ||
| 123 | (if (zerop (buffer-size)) | 131 | (if (zerop (buffer-size)) |
| 124 | (nnheader-insert "211 0 0 0 %s\n" group) | 132 | (nnheader-insert "211 0 0 0 %s\n" group) |
| 125 | (goto-char (point-min)) | 133 | (goto-char (point-min)) |
| @@ -136,15 +144,17 @@ | |||
| 136 | ;; Remove NOV lines of articles that are marked as read. | 144 | ;; Remove NOV lines of articles that are marked as read. |
| 137 | (when (and (file-exists-p (nnkiboze-nov-file-name)) | 145 | (when (and (file-exists-p (nnkiboze-nov-file-name)) |
| 138 | nnkiboze-remove-read-articles) | 146 | nnkiboze-remove-read-articles) |
| 139 | (nnheader-temp-write (nnkiboze-nov-file-name) | 147 | (let ((coding-system-for-write nnkiboze-file-coding-system)) |
| 140 | (let ((cur (current-buffer))) | 148 | (with-temp-file (nnkiboze-nov-file-name) |
| 141 | (nnheader-insert-file-contents (nnkiboze-nov-file-name)) | 149 | (let ((cur (current-buffer)) |
| 142 | (goto-char (point-min)) | 150 | (nnheader-file-coding-system nnkiboze-file-coding-system)) |
| 143 | (while (not (eobp)) | 151 | (nnheader-insert-file-contents (nnkiboze-nov-file-name)) |
| 144 | (if (not (gnus-article-read-p (read cur))) | 152 | (goto-char (point-min)) |
| 145 | (forward-line 1) | 153 | (while (not (eobp)) |
| 146 | (gnus-delete-line)))))) | 154 | (if (not (gnus-article-read-p (read cur))) |
| 147 | (setq nnkiboze-current-group nil)) | 155 | (forward-line 1) |
| 156 | (gnus-delete-line)))))) | ||
| 157 | (setq nnkiboze-current-group nil))) | ||
| 148 | 158 | ||
| 149 | (deffoo nnkiboze-open-server (server &optional defs) | 159 | (deffoo nnkiboze-open-server (server &optional defs) |
| 150 | (unless (assq 'nnkiboze-regexp defs) | 160 | (unless (assq 'nnkiboze-regexp defs) |
| @@ -155,15 +165,15 @@ | |||
| 155 | (deffoo nnkiboze-request-delete-group (group &optional force server) | 165 | (deffoo nnkiboze-request-delete-group (group &optional force server) |
| 156 | (nnkiboze-possibly-change-group group) | 166 | (nnkiboze-possibly-change-group group) |
| 157 | (when force | 167 | (when force |
| 158 | (let ((files (nconc | 168 | (let ((files (nconc |
| 159 | (nnkiboze-score-file group) | 169 | (nnkiboze-score-file group) |
| 160 | (list (nnkiboze-nov-file-name) | 170 | (list (nnkiboze-nov-file-name) |
| 161 | (nnkiboze-nov-file-name ".newsrc"))))) | 171 | (nnkiboze-nov-file-name ".newsrc"))))) |
| 162 | (while files | 172 | (while files |
| 163 | (and (file-exists-p (car files)) | 173 | (and (file-exists-p (car files)) |
| 164 | (file-writable-p (car files)) | 174 | (file-writable-p (car files)) |
| 165 | (delete-file (car files))) | 175 | (delete-file (car files))) |
| 166 | (setq files (cdr files))))) | 176 | (setq files (cdr files))))) |
| 167 | (setq nnkiboze-current-group nil) | 177 | (setq nnkiboze-current-group nil) |
| 168 | t) | 178 | t) |
| 169 | 179 | ||
| @@ -184,6 +194,7 @@ | |||
| 184 | Finds out what articles are to be part of the nnkiboze groups." | 194 | Finds out what articles are to be part of the nnkiboze groups." |
| 185 | (interactive) | 195 | (interactive) |
| 186 | (let ((nnmail-spool-file nil) | 196 | (let ((nnmail-spool-file nil) |
| 197 | (mail-sources nil) | ||
| 187 | (gnus-use-dribble-file nil) | 198 | (gnus-use-dribble-file nil) |
| 188 | (gnus-read-active-file t) | 199 | (gnus-read-active-file t) |
| 189 | (gnus-expert-user t)) | 200 | (gnus-expert-user t)) |
| @@ -209,7 +220,7 @@ Finds out what articles are to be part of the nnkiboze groups." | |||
| 209 | 220 | ||
| 210 | (defun nnkiboze-generate-group (group) | 221 | (defun nnkiboze-generate-group (group) |
| 211 | (let* ((info (nth 2 (gnus-gethash group gnus-newsrc-hashtb))) | 222 | (let* ((info (nth 2 (gnus-gethash group gnus-newsrc-hashtb))) |
| 212 | (newsrc-file (concat nnkiboze-directory | 223 | (newsrc-file (concat nnkiboze-directory |
| 213 | (nnheader-translate-file-chars | 224 | (nnheader-translate-file-chars |
| 214 | (concat group ".newsrc")))) | 225 | (concat group ".newsrc")))) |
| 215 | (nov-file (concat nnkiboze-directory | 226 | (nov-file (concat nnkiboze-directory |
| @@ -230,95 +241,96 @@ Finds out what articles are to be part of the nnkiboze groups." | |||
| 230 | ;; Load the kiboze newsrc file for this group. | 241 | ;; Load the kiboze newsrc file for this group. |
| 231 | (when (file-exists-p newsrc-file) | 242 | (when (file-exists-p newsrc-file) |
| 232 | (load newsrc-file)) | 243 | (load newsrc-file)) |
| 233 | (nnheader-temp-write nov-file | 244 | (let ((coding-system-for-write nnkiboze-file-coding-system)) |
| 234 | (when (file-exists-p nov-file) | 245 | (with-temp-file nov-file |
| 235 | (insert-file-contents nov-file)) | 246 | (when (file-exists-p nov-file) |
| 236 | (setq nov-buffer (current-buffer)) | 247 | (insert-file-contents nov-file)) |
| 237 | ;; Go through the active hashtb and add new all groups that match the | 248 | (setq nov-buffer (current-buffer)) |
| 238 | ;; kiboze regexp. | 249 | ;; Go through the active hashtb and add new all groups that match the |
| 239 | (mapatoms | 250 | ;; kiboze regexp. |
| 240 | (lambda (group) | 251 | (mapatoms |
| 241 | (and (string-match nnkiboze-regexp | 252 | (lambda (group) |
| 242 | (setq gname (symbol-name group))) ; Match | 253 | (and (string-match nnkiboze-regexp |
| 243 | (not (assoc gname nnkiboze-newsrc)) ; It isn't registered | 254 | (setq gname (symbol-name group))) ; Match |
| 244 | (numberp (car (symbol-value group))) ; It is active | 255 | (not (assoc gname nnkiboze-newsrc)) ; It isn't registered |
| 245 | (or (> nnkiboze-level 7) | 256 | (numberp (car (symbol-value group))) ; It is active |
| 246 | (and (setq glevel (nth 1 (nth 2 (gnus-gethash | 257 | (or (> nnkiboze-level 7) |
| 247 | gname gnus-newsrc-hashtb)))) | 258 | (and (setq glevel (nth 1 (nth 2 (gnus-gethash |
| 248 | (>= nnkiboze-level glevel))) | 259 | gname gnus-newsrc-hashtb)))) |
| 249 | (not (string-match "^nnkiboze:" gname)) ; Exclude kibozes | 260 | (>= nnkiboze-level glevel))) |
| 250 | (push (cons gname (1- (car (symbol-value group)))) | 261 | (not (string-match "^nnkiboze:" gname)) ; Exclude kibozes |
| 251 | nnkiboze-newsrc))) | 262 | (push (cons gname (1- (car (symbol-value group)))) |
| 252 | gnus-active-hashtb) | 263 | nnkiboze-newsrc))) |
| 253 | ;; `newsrc' is set to the list of groups that possibly are | 264 | gnus-active-hashtb) |
| 254 | ;; component groups to this kiboze group. This list has elements | 265 | ;; `newsrc' is set to the list of groups that possibly are |
| 255 | ;; on the form `(GROUP . NUMBER)', where NUMBER is the highest | 266 | ;; component groups to this kiboze group. This list has elements |
| 256 | ;; number that has been kibozed in GROUP in this kiboze group. | 267 | ;; on the form `(GROUP . NUMBER)', where NUMBER is the highest |
| 257 | (setq newsrc nnkiboze-newsrc) | 268 | ;; number that has been kibozed in GROUP in this kiboze group. |
| 258 | (while newsrc | 269 | (setq newsrc nnkiboze-newsrc) |
| 259 | (if (not (setq active (gnus-gethash | 270 | (while newsrc |
| 260 | (caar newsrc) gnus-active-hashtb))) | 271 | (if (not (setq active (gnus-gethash |
| 261 | ;; This group isn't active after all, so we remove it from | 272 | (caar newsrc) gnus-active-hashtb))) |
| 262 | ;; the list of component groups. | 273 | ;; This group isn't active after all, so we remove it from |
| 263 | (setq nnkiboze-newsrc (delq (car newsrc) nnkiboze-newsrc)) | 274 | ;; the list of component groups. |
| 264 | (setq lowest (cdar newsrc)) | 275 | (setq nnkiboze-newsrc (delq (car newsrc) nnkiboze-newsrc)) |
| 265 | ;; Ok, we have a valid component group, so we jump to it. | 276 | (setq lowest (cdar newsrc)) |
| 266 | (switch-to-buffer gnus-group-buffer) | 277 | ;; Ok, we have a valid component group, so we jump to it. |
| 267 | (gnus-group-jump-to-group (caar newsrc)) | 278 | (switch-to-buffer gnus-group-buffer) |
| 268 | (gnus-message 3 "nnkiboze: Checking %s..." (caar newsrc)) | 279 | (gnus-group-jump-to-group (caar newsrc)) |
| 269 | (setq ginfo (gnus-get-info (gnus-group-group-name)) | 280 | (gnus-message 3 "nnkiboze: Checking %s..." (caar newsrc)) |
| 270 | orig-info (gnus-copy-sequence ginfo) | 281 | (setq ginfo (gnus-get-info (gnus-group-group-name)) |
| 271 | num-unread (car (gnus-gethash (caar newsrc) | 282 | orig-info (gnus-copy-sequence ginfo) |
| 272 | gnus-newsrc-hashtb))) | 283 | num-unread (car (gnus-gethash (caar newsrc) |
| 273 | (unwind-protect | 284 | gnus-newsrc-hashtb))) |
| 274 | (progn | 285 | (unwind-protect |
| 275 | ;; We set all list of article marks to nil. Since we operate | 286 | (progn |
| 276 | ;; on copies of the real lists, we can destroy anything we | 287 | ;; We set all list of article marks to nil. Since we operate |
| 277 | ;; want here. | 288 | ;; on copies of the real lists, we can destroy anything we |
| 278 | (when (nth 3 ginfo) | 289 | ;; want here. |
| 279 | (setcar (nthcdr 3 ginfo) nil)) | 290 | (when (nth 3 ginfo) |
| 280 | ;; We set the list of read articles to be what we expect for | 291 | (setcar (nthcdr 3 ginfo) nil)) |
| 281 | ;; this kiboze group -- either nil or `(1 . LOWEST)'. | 292 | ;; We set the list of read articles to be what we expect for |
| 282 | (when ginfo | 293 | ;; this kiboze group -- either nil or `(1 . LOWEST)'. |
| 283 | (setcar (nthcdr 2 ginfo) | 294 | (when ginfo |
| 284 | (and (not (= lowest 1)) (cons 1 lowest)))) | 295 | (setcar (nthcdr 2 ginfo) |
| 285 | (when (and (or (not ginfo) | 296 | (and (not (= lowest 1)) (cons 1 lowest)))) |
| 286 | (> (length (gnus-list-of-unread-articles | 297 | (when (and (or (not ginfo) |
| 287 | (car ginfo))) | 298 | (> (length (gnus-list-of-unread-articles |
| 288 | 0)) | 299 | (car ginfo))) |
| 289 | (progn | 300 | 0)) |
| 290 | (ignore-errors | 301 | (progn |
| 291 | (gnus-group-select-group nil)) | 302 | (ignore-errors |
| 292 | (eq major-mode 'gnus-summary-mode))) | 303 | (gnus-group-select-group nil)) |
| 293 | ;; We are now in the group where we want to be. | 304 | (eq major-mode 'gnus-summary-mode))) |
| 294 | (setq method (gnus-find-method-for-group | 305 | ;; We are now in the group where we want to be. |
| 295 | gnus-newsgroup-name)) | 306 | (setq method (gnus-find-method-for-group |
| 296 | (when (eq method gnus-select-method) | 307 | gnus-newsgroup-name)) |
| 297 | (setq method nil)) | 308 | (when (eq method gnus-select-method) |
| 298 | ;; We go through the list of scored articles. | 309 | (setq method nil)) |
| 299 | (while gnus-newsgroup-scored | 310 | ;; We go through the list of scored articles. |
| 300 | (when (> (caar gnus-newsgroup-scored) lowest) | 311 | (while gnus-newsgroup-scored |
| 301 | ;; If it has a good score, then we enter this article | 312 | (when (> (caar gnus-newsgroup-scored) lowest) |
| 302 | ;; into the kiboze group. | 313 | ;; If it has a good score, then we enter this article |
| 303 | (nnkiboze-enter-nov | 314 | ;; into the kiboze group. |
| 304 | nov-buffer | 315 | (nnkiboze-enter-nov |
| 305 | (gnus-summary-article-header | 316 | nov-buffer |
| 306 | (caar gnus-newsgroup-scored)) | 317 | (gnus-summary-article-header |
| 307 | gnus-newsgroup-name)) | 318 | (caar gnus-newsgroup-scored)) |
| 308 | (setq gnus-newsgroup-scored (cdr gnus-newsgroup-scored))) | 319 | gnus-newsgroup-name)) |
| 309 | ;; That's it. We exit this group. | 320 | (setq gnus-newsgroup-scored (cdr gnus-newsgroup-scored))) |
| 310 | (when (eq major-mode 'gnus-summary-mode) | 321 | ;; That's it. We exit this group. |
| 311 | (kill-buffer (current-buffer))))) | 322 | (when (eq major-mode 'gnus-summary-mode) |
| 312 | ;; Restore the proper info. | 323 | (kill-buffer (current-buffer))))) |
| 313 | (when ginfo | 324 | ;; Restore the proper info. |
| 314 | (setcdr ginfo (cdr orig-info))) | 325 | (when ginfo |
| 315 | (setcar (gnus-gethash (caar newsrc) gnus-newsrc-hashtb) | 326 | (setcdr ginfo (cdr orig-info))) |
| 316 | num-unread))) | 327 | (setcar (gnus-gethash (caar newsrc) gnus-newsrc-hashtb) |
| 317 | (setcdr (car newsrc) (car active)) | 328 | num-unread))) |
| 318 | (gnus-message 3 "nnkiboze: Checking %s...done" (caar newsrc)) | 329 | (setcdr (car newsrc) (car active)) |
| 319 | (setq newsrc (cdr newsrc)))) | 330 | (gnus-message 3 "nnkiboze: Checking %s...done" (caar newsrc)) |
| 331 | (setq newsrc (cdr newsrc))))) | ||
| 320 | ;; We save the kiboze newsrc for this group. | 332 | ;; We save the kiboze newsrc for this group. |
| 321 | (nnheader-temp-write newsrc-file | 333 | (with-temp-file newsrc-file |
| 322 | (insert "(setq nnkiboze-newsrc '") | 334 | (insert "(setq nnkiboze-newsrc '") |
| 323 | (gnus-prin1 nnkiboze-newsrc) | 335 | (gnus-prin1 nnkiboze-newsrc) |
| 324 | (insert ")\n"))) | 336 | (insert ")\n"))) |
| @@ -340,19 +352,22 @@ Finds out what articles are to be part of the nnkiboze groups." | |||
| 340 | (forward-line 1)) | 352 | (forward-line 1)) |
| 341 | (setq article 1)) | 353 | (setq article 1)) |
| 342 | (mail-header-set-number oheader article) | 354 | (mail-header-set-number oheader article) |
| 343 | (nnheader-insert-nov oheader) | 355 | (with-temp-buffer |
| 344 | (search-backward "\t" nil t 2) | 356 | (insert (mail-header-xref oheader)) |
| 345 | (if (re-search-forward " [^ ]+:[0-9]+" nil t) | 357 | (goto-char (point-min)) |
| 346 | (goto-char (match-beginning 0)) | 358 | (if (re-search-forward " [^ ]+:[0-9]+" nil t) |
| 359 | (goto-char (match-beginning 0)) | ||
| 347 | (forward-char 1)) | 360 | (forward-char 1)) |
| 348 | ;; The first Xref has to be the group this article | 361 | ;; The first Xref has to be the group this article |
| 349 | ;; really came for - this is the article nnkiboze | 362 | ;; really came for - this is the article nnkiboze |
| 350 | ;; will request when it is asked for the article. | 363 | ;; will request when it is asked for the article. |
| 351 | (insert " " group ":" | 364 | (insert " " group ":" |
| 352 | (int-to-string (mail-header-number header)) " ") | 365 | (int-to-string (mail-header-number header)) " ") |
| 353 | (while (re-search-forward " [^ ]+:[0-9]+" nil t) | 366 | (while (re-search-forward " [^ ]+:[0-9]+" nil t) |
| 354 | (goto-char (1+ (match-beginning 0))) | 367 | (goto-char (1+ (match-beginning 0))) |
| 355 | (insert prefix))))) | 368 | (insert prefix)) |
| 369 | (mail-header-set-xref oheader (buffer-string))) | ||
| 370 | (nnheader-insert-nov oheader)))) | ||
| 356 | 371 | ||
| 357 | (defun nnkiboze-nov-file-name (&optional suffix) | 372 | (defun nnkiboze-nov-file-name (&optional suffix) |
| 358 | (concat (file-name-as-directory nnkiboze-directory) | 373 | (concat (file-name-as-directory nnkiboze-directory) |