1;;; gnus-art.el --- article mode commands for Gnus 2 3;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 4;; 2005, 2006, 2007 Free Software Foundation, Inc. 5 6;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> 7;; Keywords: news 8 9;; This file is part of GNU Emacs. 10 11;; GNU Emacs is free software; you can redistribute it and/or modify 12;; it under the terms of the GNU General Public License as published by 13;; the Free Software Foundation; either version 2, or (at your option) 14;; any later version. 15 16;; GNU Emacs is distributed in the hope that it will be useful, 17;; but WITHOUT ANY WARRANTY; without even the implied warranty of 18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19;; GNU General Public License for more details. 20 21;; You should have received a copy of the GNU General Public License 22;; along with GNU Emacs; see the file COPYING. If not, write to the 23;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 24;; Boston, MA 02110-1301, USA. 25 26;;; Commentary: 27 28;;; Code: 29 30(eval-when-compile 31 (require 'cl) 32 (defvar tool-bar-map) 33 (defvar w3m-minor-mode-map)) 34 35(require 'gnus) 36(require 'gnus-sum) 37(require 'gnus-spec) 38(require 'gnus-int) 39(require 'gnus-win) 40(require 'mm-bodies) 41(require 'mail-parse) 42(require 'mm-decode) 43(require 'mm-view) 44(require 'wid-edit) 45(require 'mm-uu) 46(require 'message) 47 48(autoload 'gnus-msg-mail "gnus-msg" nil t) 49(autoload 'gnus-button-mailto "gnus-msg") 50(autoload 'gnus-button-reply "gnus-msg" nil t) 51(autoload 'parse-time-string "parse-time" nil nil) 52(autoload 'mm-extern-cache-contents "mm-extern") 53 54(defgroup gnus-article nil 55 "Article display." 56 :link '(custom-manual "(gnus)Article Buffer") 57 :group 'gnus) 58 59(defgroup gnus-article-treat nil 60 "Treating article parts." 61 :link '(custom-manual "(gnus)Article Hiding") 62 :group 'gnus-article) 63 64(defgroup gnus-article-hiding nil 65 "Hiding article parts." 66 :link '(custom-manual "(gnus)Article Hiding") 67 :group 'gnus-article) 68 69(defgroup gnus-article-highlight nil 70 "Article highlighting." 71 :link '(custom-manual "(gnus)Article Highlighting") 72 :group 'gnus-article 73 :group 'gnus-visual) 74 75(defgroup gnus-article-signature nil 76 "Article signatures." 77 :link '(custom-manual "(gnus)Article Signature") 78 :group 'gnus-article) 79 80(defgroup gnus-article-headers nil 81 "Article headers." 82 :link '(custom-manual "(gnus)Hiding Headers") 83 :group 'gnus-article) 84 85(defgroup gnus-article-washing nil 86 "Special commands on articles." 87 :link '(custom-manual "(gnus)Article Washing") 88 :group 'gnus-article) 89 90(defgroup gnus-article-emphasis nil 91 "Fontisizing articles." 92 :link '(custom-manual "(gnus)Article Fontisizing") 93 :group 'gnus-article) 94 95(defgroup gnus-article-saving nil 96 "Saving articles." 97 :link '(custom-manual "(gnus)Saving Articles") 98 :group 'gnus-article) 99 100(defgroup gnus-article-mime nil 101 "Worshiping the MIME wonder." 102 :link '(custom-manual "(gnus)Using MIME") 103 :group 'gnus-article) 104 105(defgroup gnus-article-buttons nil 106 "Pushable buttons in the article buffer." 107 :link '(custom-manual "(gnus)Article Buttons") 108 :group 'gnus-article) 109 110(defgroup gnus-article-various nil 111 "Other article options." 112 :link '(custom-manual "(gnus)Misc Article") 113 :group 'gnus-article) 114 115(defcustom gnus-ignored-headers 116 (mapcar 117 (lambda (header) 118 (concat "^" header ":")) 119 '("Path" "Expires" "Date-Received" "References" "Xref" "Lines" 120 "Relay-Version" "Message-ID" "Approved" "Sender" "Received" 121 "X-UIDL" "MIME-Version" "Return-Path" "In-Reply-To" 122 "Content-Type" "Content-Transfer-Encoding" "X-WebTV-Signature" 123 "X-MimeOLE" "X-MSMail-Priority" "X-Priority" "X-Loop" 124 "X-Authentication-Warning" "X-MIME-Autoconverted" "X-Face" 125 "X-Attribution" "X-Originating-IP" "Delivered-To" 126 "NNTP-[-A-Za-z]+" "Distribution" "X-no-archive" "X-Trace" 127 "X-Complaints-To" "X-NNTP-Posting-Host" "X-Orig.*" 128 "Abuse-Reports-To" "Cache-Post-Path" "X-Article-Creation-Date" 129 "X-Poster" "X-Mail2News-Path" "X-Server-Date" "X-Cache" 130 "Originator" "X-Problems-To" "X-Auth-User" "X-Post-Time" 131 "X-Admin" "X-UID" "Resent-[-A-Za-z]+" "X-Mailing-List" 132 "Precedence" "Original-[-A-Za-z]+" "X-filename" "X-Orcpt" 133 "Old-Received" "X-Pgp" "X-Auth" "X-From-Line" 134 "X-Gnus-Article-Number" "X-Majordomo" "X-Url" "X-Sender" 135 "MBOX-Line" "Priority" "X400-[-A-Za-z]+" 136 "Status" "X-Gnus-Mail-Source" "Cancel-Lock" 137 "X-FTN" "X-EXP32-SerialNo" "Encoding" "Importance" 138 "Autoforwarded" "Original-Encoded-Information-Types" "X-Ya-Pop3" 139 "X-Face-Version" "X-Vms-To" "X-ML-NAME" "X-ML-COUNT" 140 "Mailing-List" "X-finfo" "X-md5sum" "X-md5sum-Origin" 141 "X-Sun-Charset" "X-Accept-Language" "X-Envelope-Sender" 142 "List-[A-Za-z]+" "X-Listprocessor-Version" 143 "X-Received" "X-Distribute" "X-Sequence" "X-Juno-Line-Breaks" 144 "X-Notes-Item" "X-MS-TNEF-Correlator" "x-uunet-gateway" 145 "X-Received" "Content-length" "X-precedence" 146 "X-Authenticated-User" "X-Comment" "X-Report" "X-Abuse-Info" 147 "X-HTTP-Proxy" "X-Mydeja-Info" "X-Copyright" "X-No-Markup" 148 "X-Abuse-Info" "X-From_" "X-Accept-Language" "Errors-To" 149 "X-BeenThere" "X-Mailman-Version" "List-Help" "List-Post" 150 "List-Subscribe" "List-Id" "List-Unsubscribe" "List-Archive" 151 "X-Content-length" "X-Posting-Agent" "Original-Received" 152 "X-Request-PGP" "X-Fingerprint" "X-WRIEnvto" "X-WRIEnvfrom" 153 "X-Virus-Scanned" "X-Delivery-Agent" "Posted-Date" "X-Gateway" 154 "X-Local-Origin" "X-Local-Destination" "X-UserInfo1" 155 "X-Received-Date" "X-Hashcash" "Face" "X-DMCA-Notifications" 156 "X-Abuse-and-DMCA-Info" "X-Postfilter" "X-Gpg-.*" "X-Disclaimer")) 157 "*All headers that start with this regexp will be hidden. 158This variable can also be a list of regexps of headers to be ignored. 159If `gnus-visible-headers' is non-nil, this variable will be ignored." 160 :type '(choice :custom-show nil 161 regexp 162 (repeat regexp)) 163 :group 'gnus-article-hiding) 164 165(defcustom gnus-visible-headers 166 "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^[BGF]?Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Mail-Followup-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|^X-Sent:" 167 "*All headers that do not match this regexp will be hidden. 168This variable can also be a list of regexp of headers to remain visible. 169If this variable is non-nil, `gnus-ignored-headers' will be ignored." 170 :type '(repeat :value-to-internal (lambda (widget value) 171 (custom-split-regexp-maybe value)) 172 :match (lambda (widget value) 173 (or (stringp value) 174 (widget-editable-list-match widget value))) 175 regexp) 176 :group 'gnus-article-hiding) 177 178(defcustom gnus-sorted-header-list 179 '("^From:" "^Subject:" "^Summary:" "^Keywords:" "^Newsgroups:" 180 "^Followup-To:" "^To:" "^Cc:" "^Date:" "^Organization:") 181 "*This variable is a list of regular expressions. 182If it is non-nil, headers that match the regular expressions will 183be placed first in the article buffer in the sequence specified by 184this list." 185 :type '(repeat regexp) 186 :group 'gnus-article-hiding) 187 188(defcustom gnus-boring-article-headers '(empty followup-to reply-to) 189 "Headers that are only to be displayed if they have interesting data. 190Possible values in this list are: 191 192 'empty Headers with no content. 193 'newsgroups Newsgroup identical to Gnus group. 194 'to-address To identical to To-address. 195 'to-list To identical to To-list. 196 'cc-list CC identical to To-list. 197 'followup-to Followup-to identical to Newsgroups. 198 'reply-to Reply-to identical to From. 199 'date Date less than four days old. 200 'long-to To and/or Cc longer than 1024 characters. 201 'many-to Multiple To and/or Cc." 202 :type '(set (const :tag "Headers with no content." empty) 203 (const :tag "Newsgroups identical to Gnus group." newsgroups) 204 (const :tag "To identical to To-address." to-address) 205 (const :tag "To identical to To-list." to-list) 206 (const :tag "CC identical to To-list." cc-list) 207 (const :tag "Followup-to identical to Newsgroups." followup-to) 208 (const :tag "Reply-to identical to From." reply-to) 209 (const :tag "Date less than four days old." date) 210 (const :tag "To and/or Cc longer than 1024 characters." long-to) 211 (const :tag "Multiple To and/or Cc headers." many-to)) 212 :group 'gnus-article-hiding) 213 214(defcustom gnus-article-skip-boring nil 215 "Skip over text that is not worth reading. 216By default, if you set this t, then Gnus will display citations and 217signatures, but will never scroll down to show you a page consisting 218only of boring text. Boring text is controlled by 219`gnus-article-boring-faces'." 220 :version "22.1" 221 :type 'boolean 222 :group 'gnus-article-hiding) 223 224(defcustom gnus-signature-separator '("^-- $" "^-- *$") 225 "Regexp matching signature separator. 226This can also be a list of regexps. In that case, it will be checked 227from head to tail looking for a separator. Searches will be done from 228the end of the buffer." 229 :type '(choice :format "%{%t%}: %[Value Menu%]\n%v" 230 (regexp) 231 (repeat :tag "List of regexp" regexp)) 232 :group 'gnus-article-signature) 233 234(defcustom gnus-signature-limit nil 235 "Provide a limit to what is considered a signature. 236If it is a number, no signature may not be longer (in characters) than 237that number. If it is a floating point number, no signature may be 238longer (in lines) than that number. If it is a function, the function 239will be called without any parameters, and if it returns nil, there is 240no signature in the buffer. If it is a string, it will be used as a 241regexp. If it matches, the text in question is not a signature." 242 :type '(choice (const nil) 243 (integer :value 200) 244 (number :value 4.0) 245 function 246 (regexp :value ".*")) 247 :group 'gnus-article-signature) 248 249(defcustom gnus-hidden-properties '(invisible t intangible t) 250 "Property list to use for hiding text." 251 :type 'sexp 252 :group 'gnus-article-hiding) 253 254;; Fixme: This isn't the right thing for mixed graphical and non-graphical 255;; frames in a session. 256(defcustom gnus-article-x-face-command 257 (if (featurep 'xemacs) 258 (if (or (gnus-image-type-available-p 'xface) 259 (gnus-image-type-available-p 'pbm)) 260 'gnus-display-x-face-in-from 261 "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | ee -") 262 (if (gnus-image-type-available-p 'pbm) 263 'gnus-display-x-face-in-from 264 "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | \ 265display -")) 266 "*String or function to be executed to display an X-Face header. 267If it is a string, the command will be executed in a sub-shell 268asynchronously. The compressed face will be piped to this command." 269 :type `(choice string 270 (function-item gnus-display-x-face-in-from) 271 function) 272 :version "21.1" 273 :group 'gnus-picon 274 :group 'gnus-article-washing) 275 276(defcustom gnus-article-x-face-too-ugly nil 277 "Regexp matching posters whose face shouldn't be shown automatically." 278 :type '(choice regexp (const nil)) 279 :group 'gnus-article-washing) 280 281(defcustom gnus-article-banner-alist nil 282 "Banner alist for stripping. 283For example, 284 ((egroups . \"^[ \\t\\n]*-------------------+\\\\( \\\\(e\\\\|Yahoo! \\\\)Groups Sponsor -+\\\\)?....\\n\\\\(.+\\n\\\\)+\"))" 285 :version "21.1" 286 :type '(repeat (cons symbol regexp)) 287 :group 'gnus-article-washing) 288 289(gnus-define-group-parameter 290 banner 291 :variable-document 292 "Alist of regexps (to match group names) and banner." 293 :variable-group gnus-article-washing 294 :parameter-type 295 '(choice :tag "Banner" 296 :value nil 297 (const :tag "Remove signature" signature) 298 (symbol :tag "Item in `gnus-article-banner-alist'" none) 299 regexp 300 (const :tag "None" nil)) 301 :parameter-document 302 "If non-nil, specify how to remove `banners' from articles. 303 304Symbol `signature' means to remove signatures delimited by 305`gnus-signature-separator'. Any other symbol is used to look up a 306regular expression to match the banner in `gnus-article-banner-alist'. 307A string is used as a regular expression to match the banner 308directly.") 309 310(defcustom gnus-article-address-banner-alist nil 311 "Alist of mail addresses and banners. 312Each element has the form (ADDRESS . BANNER), where ADDRESS is a regexp 313to match a mail address in the From: header, BANNER is one of a symbol 314`signature', an item in `gnus-article-banner-alist', a regexp and nil. 315If ADDRESS matches author's mail address, it will remove things like 316advertisements. For example: 317 318\((\"@yoo-hoo\\\\.co\\\\.jp\\\\'\" . \"\\n_+\\nDo You Yoo-hoo!\\\\?\\n.*\\n.*\\n\")) 319" 320 :type '(repeat 321 (cons 322 (regexp :tag "Address") 323 (choice :tag "Banner" :value nil 324 (const :tag "Remove signature" signature) 325 (symbol :tag "Item in `gnus-article-banner-alist'" none) 326 regexp 327 (const :tag "None" nil)))) 328 :version "22.1" 329 :group 'gnus-article-washing) 330 331(defmacro gnus-emphasis-custom-with-format (&rest body) 332 `(let ((format "\ 333\\(\\s-\\|^\\|\\=\\|[-\"]\\|\\s(\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\ 334\\(\\([-,.;:!?\"]\\|\\s)\\)+\\s-\\|[?!.]\\s-\\|\\s)\\|\\s-\\)")) 335 ,@body)) 336 337(defun gnus-emphasis-custom-value-to-external (value) 338 (gnus-emphasis-custom-with-format 339 (if (consp (car value)) 340 (list (format format (car (car value)) (cdr (car value))) 341 2 342 (if (nth 1 value) 2 3) 343 (nth 2 value)) 344 value))) 345 346(defun gnus-emphasis-custom-value-to-internal (value) 347 (gnus-emphasis-custom-with-format 348 (let ((regexp (concat "\\`" 349 (format (regexp-quote format) 350 "\\([^()]+\\)" "\\([^()]+\\)") 351 "\\'")) 352 pattern) 353 (if (string-match regexp (setq pattern (car value))) 354 (list (cons (match-string 1 pattern) (match-string 2 pattern)) 355 (= (nth 2 value) 2) 356 (nth 3 value)) 357 value)))) 358 359(defcustom gnus-emphasis-alist 360 (let ((types 361 '(("\\*" "\\*" bold nil 2) 362 ("_" "_" underline) 363 ("/" "/" italic) 364 ("_/" "/_" underline-italic) 365 ("_\\*" "\\*_" underline-bold) 366 ("\\*/" "/\\*" bold-italic) 367 ("_\\*/" "/\\*_" underline-bold-italic)))) 368 (nconc 369 (gnus-emphasis-custom-with-format 370 (mapcar (lambda (spec) 371 (list (format format (car spec) (cadr spec)) 372 (or (nth 3 spec) 2) 373 (or (nth 4 spec) 3) 374 (intern (format "gnus-emphasis-%s" (nth 2 spec))))) 375 types)) 376 '(;; I've never seen anyone use this strikethru convention whereas I've 377 ;; several times seen it triggered by normal text. --Stef 378 ;; Miles suggests that this form is sometimes used but for italics, 379 ;; so maybe we should map it to `italic'. 380 ;; ("\\(\\s-\\|^\\)\\(-\\(\\(\\w\\|-[^-]\\)+\\)-\\)\\(\\s-\\|[?!.,;]\\)" 381 ;; 2 3 gnus-emphasis-strikethru) 382 ("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)" 383 2 3 gnus-emphasis-underline)))) 384 "*Alist that says how to fontify certain phrases. 385Each item looks like this: 386 387 (\"_\\\\(\\\\w+\\\\)_\" 0 1 'underline) 388 389The first element is a regular expression to be matched. The second 390is a number that says what regular expression grouping used to find 391the entire emphasized word. The third is a number that says what 392regexp grouping should be displayed and highlighted. The fourth 393is the face used for highlighting." 394 :type 395 '(repeat 396 (menu-choice 397 :format "%[Customizing Style%]\n%v" 398 :indent 2 399 (group :tag "Default" 400 :value ("" 0 0 default) 401 :value-create 402 (lambda (widget) 403 (let ((value (widget-get 404 (cadr (widget-get (widget-get widget :parent) 405 :args)) 406 :value))) 407 (if (not (eq (nth 2 value) 'default)) 408 (widget-put 409 widget 410 :value 411 (gnus-emphasis-custom-value-to-external value)))) 412 (widget-group-value-create widget)) 413 regexp 414 (integer :format "Match group: %v") 415 (integer :format "Emphasize group: %v") 416 face) 417 (group :tag "Simple" 418 :value (("_" . "_") nil default) 419 (cons :format "%v" 420 (regexp :format "Start regexp: %v") 421 (regexp :format "End regexp: %v")) 422 (boolean :format "Show start and end patterns: %[%v%]\n" 423 :on " On " :off " Off ") 424 face))) 425 :get (lambda (symbol) 426 (mapcar 'gnus-emphasis-custom-value-to-internal 427 (default-value symbol))) 428 :set (lambda (symbol value) 429 (set-default symbol (mapcar 'gnus-emphasis-custom-value-to-external 430 value))) 431 :group 'gnus-article-emphasis) 432 433(defcustom gnus-emphasize-whitespace-regexp "^[ \t]+\\|[ \t]*\n" 434 "A regexp to describe whitespace which should not be emphasized. 435Typical values are \"^[ \\t]+\\\\|[ \\t]*\\n\" and \"[ \\t]+\\\\|[ \\t]*\\n\". 436The former avoids underlining of leading and trailing whitespace, 437and the latter avoids underlining any whitespace at all." 438 :version "21.1" 439 :group 'gnus-article-emphasis 440 :type 'regexp) 441 442(defface gnus-emphasis-bold '((t (:bold t))) 443 "Face used for displaying strong emphasized text (*word*)." 444 :group 'gnus-article-emphasis) 445 446(defface gnus-emphasis-italic '((t (:italic t))) 447 "Face used for displaying italic emphasized text (/word/)." 448 :group 'gnus-article-emphasis) 449 450(defface gnus-emphasis-underline '((t (:underline t))) 451 "Face used for displaying underlined emphasized text (_word_)." 452 :group 'gnus-article-emphasis) 453 454(defface gnus-emphasis-underline-bold '((t (:bold t :underline t))) 455 "Face used for displaying underlined bold emphasized text (_*word*_)." 456 :group 'gnus-article-emphasis) 457 458(defface gnus-emphasis-underline-italic '((t (:italic t :underline t))) 459 "Face used for displaying underlined italic emphasized text (_/word/_)." 460 :group 'gnus-article-emphasis) 461 462(defface gnus-emphasis-bold-italic '((t (:bold t :italic t))) 463 "Face used for displaying bold italic emphasized text (/*word*/)." 464 :group 'gnus-article-emphasis) 465 466(defface gnus-emphasis-underline-bold-italic 467 '((t (:bold t :italic t :underline t))) 468 "Face used for displaying underlined bold italic emphasized text. 469Example: (_/*word*/_)." 470 :group 'gnus-article-emphasis) 471 472(defface gnus-emphasis-strikethru (if (featurep 'xemacs) 473 '((t (:strikethru t))) 474 '((t (:strike-through t)))) 475 "Face used for displaying strike-through text (-word-)." 476 :group 'gnus-article-emphasis) 477 478(defface gnus-emphasis-highlight-words 479 '((t (:background "black" :foreground "yellow"))) 480 "Face used for displaying highlighted words." 481 :group 'gnus-article-emphasis) 482 483(defcustom gnus-article-time-format "%a, %b %d %Y %T %Z" 484 "Format for display of Date headers in article bodies. 485See `format-time-string' for the possible values. 486 487The variable can also be function, which should return a complete Date 488header. The function is called with one argument, the time, which can 489be fed to `format-time-string'." 490 :type '(choice string symbol) 491 :link '(custom-manual "(gnus)Article Date") 492 :group 'gnus-article-washing) 493 494(defcustom gnus-save-all-headers t 495 "*If non-nil, don't remove any headers before saving. 496This will be overridden by the `:headers' property that the symbol of 497the saver function, which is specified by `gnus-default-article-saver', 498might have." 499 :group 'gnus-article-saving 500 :type 'boolean) 501 502(defcustom gnus-prompt-before-saving 'always 503 "*This variable says how much prompting is to be done when saving articles. 504If it is nil, no prompting will be done, and the articles will be 505saved to the default files. If this variable is `always', each and 506every article that is saved will be preceded by a prompt, even when 507saving large batches of articles. If this variable is neither nil not 508`always', there the user will be prompted once for a file name for 509each invocation of the saving commands." 510 :group 'gnus-article-saving 511 :type '(choice (item always) 512 (item :tag "never" nil) 513 (sexp :tag "once" :format "%t\n" :value t))) 514 515(defcustom gnus-saved-headers gnus-visible-headers 516 "Headers to keep if `gnus-save-all-headers' is nil. 517If `gnus-save-all-headers' is non-nil, this variable will be ignored. 518If that variable is nil, however, all headers that match this regexp 519will be kept while the rest will be deleted before saving. This and 520`gnus-save-all-headers' will be overridden by the `:headers' property 521that the symbol of the saver function, which is specified by 522`gnus-default-article-saver', might have." 523 :group 'gnus-article-saving 524 :type 'regexp) 525 526(defcustom gnus-default-article-saver 'gnus-summary-save-in-rmail 527 "A function to save articles in your favourite format. 528The function will be called by way of the `gnus-summary-save-article' 529command, and friends such as `gnus-summary-save-article-rmail'. 530 531Gnus provides the following functions: 532 533* gnus-summary-save-in-rmail (Rmail format) 534* gnus-summary-save-in-mail (Unix mail format) 535* gnus-summary-save-in-folder (MH folder) 536* gnus-summary-save-in-file (article format) 537* gnus-summary-save-body-in-file (article body) 538* gnus-summary-save-in-vm (use VM's folder format) 539* gnus-summary-write-to-file (article format -- overwrite) 540* gnus-summary-write-body-to-file (article body -- overwrite) 541 542The symbol of each function may have the following properties: 543 544* :decode 545The value non-nil means save decoded articles. This is meaningful 546only with `gnus-summary-save-in-file', `gnus-summary-save-body-in-file', 547`gnus-summary-write-to-file', and `gnus-summary-write-body-to-file'. 548 549* :function 550The value specifies an alternative function which appends, not 551overwrites, articles to a file. This implies that when saving many 552articles at a time, `gnus-prompt-before-saving' is bound to t and all 553articles are saved in a single file. This is meaningful only with 554`gnus-summary-write-to-file' and `gnus-summary-write-body-to-file'. 555 556* :headers 557The value specifies the symbol of a variable of which the value 558specifies headers to be saved. If it is omitted, 559`gnus-save-all-headers' and `gnus-saved-headers' control what 560headers should be saved." 561 :group 'gnus-article-saving 562 :type '(radio (function-item gnus-summary-save-in-rmail) 563 (function-item gnus-summary-save-in-mail) 564 (function-item gnus-summary-save-in-folder) 565 (function-item gnus-summary-save-in-file) 566 (function-item gnus-summary-save-body-in-file) 567 (function-item gnus-summary-save-in-vm) 568 (function-item gnus-summary-write-to-file) 569 (function-item gnus-summary-write-body-to-file) 570 (function))) 571 572(defcustom gnus-article-save-coding-system 573 (or (and (mm-coding-system-p 'utf-8) 'utf-8) 574 (and (mm-coding-system-p 'iso-2022-7bit) 'iso-2022-7bit) 575 (and (mm-coding-system-p 'emacs-mule) 'emacs-mule) 576 (and (mm-coding-system-p 'escape-quoted) 'escape-quoted)) 577 "Coding system used to save decoded articles to a file. 578 579The recommended coding systems are `utf-8', `iso-2022-7bit' and so on, 580which can safely encode any characters in text. This is used by the 581commands including: 582 583* gnus-summary-save-article-file 584* gnus-summary-save-article-body-file 585* gnus-summary-write-article-file 586* gnus-summary-write-article-body-file 587 588and the functions to which you may set `gnus-default-article-saver': 589 590* gnus-summary-save-in-file 591* gnus-summary-save-body-in-file 592* gnus-summary-write-to-file 593* gnus-summary-write-body-to-file 594 595Those commands and functions save just text displayed in the article 596buffer to a file if the value of this variable is non-nil. Note that 597buttonized MIME parts will be lost in a saved file in that case. 598Otherwise, raw articles will be saved." 599 :group 'gnus-article-saving 600 :type `(choice 601 :format "%{%t%}:\n %[Value Menu%] %v" 602 (const :tag "Save raw articles" nil) 603 ,@(delq nil 604 (mapcar 605 (lambda (arg) (if (mm-coding-system-p (nth 3 arg)) arg)) 606 '((const :tag "UTF-8" utf-8) 607 (const :tag "iso-2022-7bit" iso-2022-7bit) 608 (const :tag "Emacs internal" emacs-mule) 609 (const :tag "escape-quoted" escape-quoted)))) 610 (symbol :tag "Coding system"))) 611 612(defcustom gnus-rmail-save-name 'gnus-plain-save-name 613 "A function generating a file name to save articles in Rmail format. 614The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE." 615 :group 'gnus-article-saving 616 :type 'function) 617 618(defcustom gnus-mail-save-name 'gnus-plain-save-name 619 "A function generating a file name to save articles in Unix mail format. 620The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE." 621 :group 'gnus-article-saving 622 :type 'function) 623 624(defcustom gnus-folder-save-name 'gnus-folder-save-name 625 "A function generating a file name to save articles in MH folder. 626The function is called with NEWSGROUP, HEADERS, and optional LAST-FOLDER." 627 :group 'gnus-article-saving 628 :type 'function) 629 630(defcustom gnus-file-save-name 'gnus-numeric-save-name 631 "A function generating a file name to save articles in article format. 632The function is called with NEWSGROUP, HEADERS, and optional 633LAST-FILE." 634 :group 'gnus-article-saving 635 :type 'function) 636 637(defcustom gnus-split-methods 638 '((gnus-article-archive-name) 639 (gnus-article-nndoc-name)) 640 "*Variable used to suggest where articles are to be saved. 641For instance, if you would like to save articles related to Gnus in 642the file \"gnus-stuff\", and articles related to VM in \"vm-stuff\", 643you could set this variable to something like: 644 645 '((\"^Subject:.*gnus\\|^Newsgroups:.*gnus\" \"gnus-stuff\") 646 (\"^Subject:.*vm\\|^Xref:.*vm\" \"vm-stuff\")) 647 648This variable is an alist where the where the key is the match and the 649value is a list of possible files to save in if the match is non-nil. 650 651If the match is a string, it is used as a regexp match on the 652article. If the match is a symbol, that symbol will be funcalled 653from the buffer of the article to be saved with the newsgroup as the 654parameter. If it is a list, it will be evaled in the same buffer. 655 656If this form or function returns a string, this string will be used as 657a possible file name; and if it returns a non-nil list, that list will 658be used as possible file names." 659 :group 'gnus-article-saving 660 :type '(repeat (choice (list :value (fun) function) 661 (cons :value ("" "") regexp (repeat string)) 662 (sexp :value nil)))) 663 664(defcustom gnus-page-delimiter "^\^L" 665 "*Regexp describing what to use as article page delimiters. 666The default value is \"^\^L\", which is a form linefeed at the 667beginning of a line." 668 :type 'regexp 669 :group 'gnus-article-various) 670 671(defcustom gnus-article-mode-line-format "Gnus: %g [%w] %S%m" 672 "*The format specification for the article mode line. 673See `gnus-summary-mode-line-format' for a closer description. 674 675The following additional specs are available: 676 677%w The article washing status. 678%m The number of MIME parts in the article." 679 :type 'string 680 :group 'gnus-article-various) 681 682(defcustom gnus-article-mode-hook nil 683 "*A hook for Gnus article mode." 684 :type 'hook 685 :group 'gnus-article-various) 686 687(when (featurep 'xemacs) 688 ;; Extracted from gnus-xmas-define in order to preserve user settings 689 (when (fboundp 'turn-off-scroll-in-place) 690 (add-hook 'gnus-article-mode-hook 'turn-off-scroll-in-place)) 691 ;; Extracted from gnus-xmas-redefine in order to preserve user settings 692 (add-hook 'gnus-article-mode-hook 'gnus-xmas-article-menu-add)) 693 694(defcustom gnus-article-menu-hook nil 695 "*Hook run after the creation of the article mode menu." 696 :type 'hook 697 :group 'gnus-article-various) 698 699(defcustom gnus-article-prepare-hook nil 700 "*A hook called after an article has been prepared in the article buffer." 701 :type 'hook 702 :group 'gnus-article-various) 703 704(make-obsolete-variable 'gnus-article-hide-pgp-hook 705 "This variable is obsolete in Gnus 5.10.") 706 707(defcustom gnus-article-button-face 'bold 708 "Face used for highlighting buttons in the article buffer. 709 710An article button is a piece of text that you can activate by pressing 711`RET' or `mouse-2' above it." 712 :type 'face 713 :group 'gnus-article-buttons) 714 715(defcustom gnus-article-mouse-face 'highlight 716 "Face used for mouse highlighting in the article buffer. 717 718Article buttons will be displayed in this face when the cursor is 719above them." 720 :type 'face 721 :group 'gnus-article-buttons) 722 723(defcustom gnus-signature-face 'gnus-signature 724 "Face used for highlighting a signature in the article buffer. 725Obsolete; use the face `gnus-signature' for customizations instead." 726 :type 'face 727 :group 'gnus-article-highlight 728 :group 'gnus-article-signature) 729 730(defface gnus-signature 731 '((t 732 (:italic t))) 733 "Face used for highlighting a signature in the article buffer." 734 :group 'gnus-article-highlight 735 :group 'gnus-article-signature) 736;; backward-compatibility alias 737(put 'gnus-signature-face 'face-alias 'gnus-signature) 738 739(defface gnus-header-from 740 '((((class color) 741 (background dark)) 742 (:foreground "spring green")) 743 (((class color) 744 (background light)) 745 (:foreground "red3")) 746 (t 747 (:italic t))) 748 "Face used for displaying from headers." 749 :group 'gnus-article-headers 750 :group 'gnus-article-highlight) 751;; backward-compatibility alias 752(put 'gnus-header-from-face 'face-alias 'gnus-header-from) 753 754(defface gnus-header-subject 755 '((((class color) 756 (background dark)) 757 (:foreground "SeaGreen3")) 758 (((class color) 759 (background light)) 760 (:foreground "red4")) 761 (t 762 (:bold t :italic t))) 763 "Face used for displaying subject headers." 764 :group 'gnus-article-headers 765 :group 'gnus-article-highlight) 766;; backward-compatibility alias 767(put 'gnus-header-subject-face 'face-alias 'gnus-header-subject) 768 769(defface gnus-header-newsgroups 770 '((((class color) 771 (background dark)) 772 (:foreground "yellow" :italic t)) 773 (((class color) 774 (background light)) 775 (:foreground "MidnightBlue" :italic t)) 776 (t 777 (:italic t))) 778 "Face used for displaying newsgroups headers. 779In the default setup this face is only used for crossposted 780articles." 781 :group 'gnus-article-headers 782 :group 'gnus-article-highlight) 783;; backward-compatibility alias 784(put 'gnus-header-newsgroups-face 'face-alias 'gnus-header-newsgroups) 785 786(defface gnus-header-name 787 '((((class color) 788 (background dark)) 789 (:foreground "SeaGreen")) 790 (((class color) 791 (background light)) 792 (:foreground "maroon")) 793 (t 794 (:bold t))) 795 "Face used for displaying header names." 796 :group 'gnus-article-headers 797 :group 'gnus-article-highlight) 798;; backward-compatibility alias 799(put 'gnus-header-name-face 'face-alias 'gnus-header-name) 800 801(defface gnus-header-content 802 '((((class color) 803 (background dark)) 804 (:foreground "forest green" :italic t)) 805 (((class color) 806 (background light)) 807 (:foreground "indianred4" :italic t)) 808 (t 809 (:italic t))) "Face used for displaying header content." 810 :group 'gnus-article-headers 811 :group 'gnus-article-highlight) 812;; backward-compatibility alias 813(put 'gnus-header-content-face 'face-alias 'gnus-header-content) 814 815(defcustom gnus-header-face-alist 816 '(("From" nil gnus-header-from) 817 ("Subject" nil gnus-header-subject) 818 ("Newsgroups:.*," nil gnus-header-newsgroups) 819 ("" gnus-header-name gnus-header-content)) 820 "*Controls highlighting of article headers. 821 822An alist of the form (HEADER NAME CONTENT). 823 824HEADER is a regular expression which should match the name of a 825header and NAME and CONTENT are either face names or nil. 826 827The name of each header field will be displayed using the face 828specified by the first element in the list where HEADER matches 829the header name and NAME is non-nil. Similarly, the content will 830be displayed by the first non-nil matching CONTENT face." 831 :group 'gnus-article-headers 832 :group 'gnus-article-highlight 833 :type '(repeat (list (regexp :tag "Header") 834 (choice :tag "Name" 835 (item :tag "skip" nil) 836 (face :value default)) 837 (choice :tag "Content" 838 (item :tag "skip" nil) 839 (face :value default))))) 840 841(defcustom gnus-article-decode-hook 842 '(article-decode-charset article-decode-encoded-words 843 article-decode-group-name article-decode-idna-rhs) 844 "*Hook run to decode charsets in articles." 845 :group 'gnus-article-headers 846 :type 'hook) 847 848(defcustom gnus-display-mime-function 'gnus-display-mime 849 "Function to display MIME articles." 850 :group 'gnus-article-mime 851 :type 'function) 852 853(defvar gnus-decode-header-function 'mail-decode-encoded-word-region 854 "Function used to decode headers.") 855 856(defvar gnus-decode-address-function 'mail-decode-encoded-address-region 857 "Function used to decode addresses.") 858 859(defvar gnus-article-dumbquotes-map 860 '(("\200" "EUR") 861 ("\202" ",") 862 ("\203" "f") 863 ("\204" ",,") 864 ("\205" "...") 865 ("\213" "<") 866 ("\214" "OE") 867 ("\221" "`") 868 ("\222" "'") 869 ("\223" "``") 870 ("\224" "\"") 871 ("\225" "*") 872 ("\226" "-") 873 ("\227" "--") 874 ("\230" "~") 875 ("\231" "(TM)") 876 ("\233" ">") 877 ("\234" "oe") 878 ("\264" "'")) 879 "Table for MS-to-Latin1 translation.") 880 881(defcustom gnus-ignored-mime-types nil 882 "List of MIME types that should be ignored by Gnus." 883 :version "21.1" 884 :group 'gnus-article-mime 885 :type '(repeat regexp)) 886 887(defcustom gnus-unbuttonized-mime-types '(".*/.*") 888 "List of MIME types that should not be given buttons when rendered inline. 889See also `gnus-buttonized-mime-types' which may override this variable. 890This variable is only used when `gnus-inhibit-mime-unbuttonizing' is nil." 891 :version "21.1" 892 :group 'gnus-article-mime 893 :type '(repeat regexp)) 894 895(defcustom gnus-buttonized-mime-types nil 896 "List of MIME types that should be given buttons when rendered inline. 897If set, this variable overrides `gnus-unbuttonized-mime-types'. 898To see e.g. security buttons you could set this to 899`(\"multipart/signed\")'. You could also add \"multipart/alternative\" to 900this list to display radio buttons that allow you to choose one of two 901media types those mails include. See also `mm-discouraged-alternatives'. 902This variable is only used when `gnus-inhibit-mime-unbuttonizing' is nil." 903 :version "22.1" 904 :group 'gnus-article-mime 905 :type '(repeat regexp)) 906 907(defcustom gnus-inhibit-mime-unbuttonizing nil 908 "If non-nil, all MIME parts get buttons. 909When nil (the default value), then some MIME parts do not get buttons, 910as described by the variables `gnus-buttonized-mime-types' and 911`gnus-unbuttonized-mime-types'." 912 :version "22.1" 913 :group 'gnus-article-mime 914 :type 'boolean) 915 916(defcustom gnus-body-boundary-delimiter "_" 917 "String used to delimit header and body. 918This variable is used by `gnus-article-treat-body-boundary' which can 919be controlled by `gnus-treat-body-boundary'." 920 :version "22.1" 921 :group 'gnus-article-various 922 :type '(choice (item :tag "None" :value nil) 923 string)) 924 925(defcustom gnus-picon-databases '("/usr/lib/picon" "/usr/local/faces" 926 "/usr/share/picons") 927 "Defines the location of the faces database. 928For information on obtaining this database of pretty pictures, please 929see http://www.cs.indiana.edu/picons/ftp/index.html" 930 :version "22.1" 931 :type '(repeat directory) 932 :link '(url-link :tag "download" 933 "http://www.cs.indiana.edu/picons/ftp/index.html") 934 :link '(custom-manual "(gnus)Picons") 935 :group 'gnus-picon) 936 937(defun gnus-picons-installed-p () 938 "Say whether picons are installed on your machine." 939 (let ((installed nil)) 940 (dolist (database gnus-picon-databases) 941 (when (file-exists-p database) 942 (setq installed t))) 943 installed)) 944 945(defcustom gnus-article-mime-part-function nil 946 "Function called with a MIME handle as the argument. 947This is meant for people who want to do something automatic based 948on parts -- for instance, adding Vcard info to a database." 949 :group 'gnus-article-mime 950 :type '(choice (const nil) 951 function)) 952 953(defcustom gnus-mime-multipart-functions nil 954 "An alist of MIME types to functions to display them." 955 :version "21.1" 956 :group 'gnus-article-mime 957 :type 'alist) 958 959(defcustom gnus-article-date-lapsed-new-header nil 960 "Whether the X-Sent and Date headers can coexist. 961When using `gnus-treat-date-lapsed', the \"X-Sent:\" header will 962either replace the old \"Date:\" header (if this variable is nil), or 963be added below it (otherwise)." 964 :version "21.1" 965 :group 'gnus-article-headers 966 :type 'boolean) 967 968(defcustom gnus-article-mime-match-handle-function 'undisplayed-alternative 969 "Function called with a MIME handle as the argument. 970This is meant for people who want to view first matched part. 971For `undisplayed-alternative' (default), the first undisplayed 972part or alternative part is used. For `undisplayed', the first 973undisplayed part is used. For a function, the first part which 974the function return t is used. For nil, the first part is 975used." 976 :version "21.1" 977 :group 'gnus-article-mime 978 :type '(choice 979 (item :tag "first" :value nil) 980 (item :tag "undisplayed" :value undisplayed) 981 (item :tag "undisplayed or alternative" 982 :value undisplayed-alternative) 983 (function))) 984 985(defcustom gnus-mime-action-alist 986 '(("save to file" . gnus-mime-save-part) 987 ("save and strip" . gnus-mime-save-part-and-strip) 988 ("delete part" . gnus-mime-delete-part) 989 ("display as text" . gnus-mime-inline-part) 990 ("view the part" . gnus-mime-view-part) 991 ("pipe to command" . gnus-mime-pipe-part) 992 ("toggle display" . gnus-article-press-button) 993 ("toggle display" . gnus-article-view-part-as-charset) 994 ("view as type" . gnus-mime-view-part-as-type) 995 ("view internally" . gnus-mime-view-part-internally) 996 ("view externally" . gnus-mime-view-part-externally)) 997 "An alist of actions that run on the MIME attachment." 998 :group 'gnus-article-mime 999 :type '(repeat (cons (string :tag "name") 1000 (function)))) 1001 1002;;; 1003;;; The treatment variables 1004;;; 1005 1006(defvar gnus-part-display-hook nil 1007 "Hook called on parts that are to receive treatment.") 1008 1009(defvar gnus-article-treat-custom 1010 '(choice (const :tag "Off" nil) 1011 (const :tag "On" t) 1012 (const :tag "Header" head) 1013 (const :tag "Last" last) 1014 (integer :tag "Less") 1015 (repeat :tag "Groups" regexp) 1016 (sexp :tag "Predicate"))) 1017 1018(defvar gnus-article-treat-head-custom 1019 '(choice (const :tag "Off" nil) 1020 (const :tag "Header" head))) 1021 1022(defvar gnus-article-treat-types '("text/plain") 1023 "Parts to treat.") 1024 1025(defvar gnus-inhibit-treatment nil 1026 "Whether to inhibit treatment.") 1027 1028(defcustom gnus-treat-highlight-signature '(or t (typep "text/x-vcard")) 1029 "Highlight the signature. 1030Valid values are nil, t, `head', `last', an integer or a predicate. 1031See Info node `(gnus)Customizing Articles'." 1032 :group 'gnus-article-treat 1033 :link '(custom-manual "(gnus)Customizing Articles") 1034 :type gnus-article-treat-custom) 1035(put 'gnus-treat-highlight-signature 'highlight t) 1036 1037(defcustom gnus-treat-buttonize 100000 1038 "Add buttons. 1039Valid values are nil, t, `head', `last', an integer or a predicate. 1040See Info node `(gnus)Customizing Articles'." 1041 :group 'gnus-article-treat 1042 :link '(custom-manual "(gnus)Customizing Articles") 1043 :type gnus-article-treat-custom) 1044(put 'gnus-treat-buttonize 'highlight t) 1045 1046(defcustom gnus-treat-buttonize-head 'head 1047 "Add buttons to the head. 1048Valid values are nil, t, `head', `last', an integer or a predicate. 1049See Info node `(gnus)Customizing Articles' for details." 1050 :group 'gnus-article-treat 1051 :link '(custom-manual "(gnus)Customizing Articles") 1052 :type gnus-article-treat-head-custom) 1053(put 'gnus-treat-buttonize-head 'highlight t) 1054 1055(defcustom gnus-treat-emphasize 1056 (and (or window-system 1057 (featurep 'xemacs) 1058 (>= (string-to-number emacs-version) 21)) 1059 50000) 1060 "Emphasize text. 1061Valid values are nil, t, `head', `last', an integer or a predicate. 1062See Info node `(gnus)Customizing Articles' for details." 1063 :group 'gnus-article-treat 1064 :link '(custom-manual "(gnus)Customizing Articles") 1065 :type gnus-article-treat-custom) 1066(put 'gnus-treat-emphasize 'highlight t) 1067 1068(defcustom gnus-treat-strip-cr nil 1069 "Remove carriage returns. 1070Valid values are nil, t, `head', `last', an integer or a predicate. 1071See Info node `(gnus)Customizing Articles' for details." 1072 :version "22.1" 1073 :group 'gnus-article-treat 1074 :link '(custom-manual "(gnus)Customizing Articles") 1075 :type gnus-article-treat-custom) 1076 1077(defcustom gnus-treat-unsplit-urls nil 1078 "Remove newlines from within URLs. 1079Valid values are nil, t, `head', `last', an integer or a predicate. 1080See Info node `(gnus)Customizing Articles' for details." 1081 :version "22.1" 1082 :group 'gnus-article-treat 1083 :link '(custom-manual "(gnus)Customizing Articles") 1084 :type gnus-article-treat-custom) 1085 1086(defcustom gnus-treat-leading-whitespace nil 1087 "Remove leading whitespace in headers. 1088Valid values are nil, t, `head', `last', an integer or a predicate. 1089See Info node `(gnus)Customizing Articles' for details." 1090 :version "22.1" 1091 :group 'gnus-article-treat 1092 :link '(custom-manual "(gnus)Customizing Articles") 1093 :type gnus-article-treat-custom) 1094 1095(defcustom gnus-treat-hide-headers 'head 1096 "Hide headers. 1097Valid values are nil, t, `head', `last', an integer or a predicate. 1098See Info node `(gnus)Customizing Articles' for details." 1099 :group 'gnus-article-treat 1100 :link '(custom-manual "(gnus)Customizing Articles") 1101 :type gnus-article-treat-head-custom) 1102 1103(defcustom gnus-treat-hide-boring-headers nil 1104 "Hide boring headers. 1105Valid values are nil, t, `head', `last', an integer or a predicate. 1106See Info node `(gnus)Customizing Articles' for details." 1107 :group 'gnus-article-treat 1108 :link '(custom-manual "(gnus)Customizing Articles") 1109 :type gnus-article-treat-head-custom) 1110 1111(defcustom gnus-treat-hide-signature nil 1112 "Hide the signature. 1113Valid values are nil, t, `head', `last', an integer or a predicate. 1114See Info node `(gnus)Customizing Articles' for details." 1115 :group 'gnus-article-treat 1116 :link '(custom-manual "(gnus)Customizing Articles") 1117 :type gnus-article-treat-custom) 1118 1119(defcustom gnus-treat-fill-article nil 1120 "Fill the article. 1121Valid values are nil, t, `head', `last', an integer or a predicate. 1122See Info node `(gnus)Customizing Articles' for details." 1123 :group 'gnus-article-treat 1124 :link '(custom-manual "(gnus)Customizing Articles") 1125 :type gnus-article-treat-custom) 1126 1127(defcustom gnus-treat-hide-citation nil 1128 "Hide cited text. 1129Valid values are nil, t, `head', `last', an integer or a predicate. 1130See Info node `(gnus)Customizing Articles' for details." 1131 :group 'gnus-article-treat 1132 :link '(custom-manual "(gnus)Customizing Articles") 1133 :type gnus-article-treat-custom) 1134 1135(defcustom gnus-treat-hide-citation-maybe nil 1136 "Hide cited text. 1137Valid values are nil, t, `head', `last', an integer or a predicate. 1138See Info node `(gnus)Customizing Articles' for details." 1139 :group 'gnus-article-treat 1140 :link '(custom-manual "(gnus)Customizing Articles") 1141 :type gnus-article-treat-custom) 1142 1143(defcustom gnus-treat-strip-list-identifiers 'head 1144 "Strip list identifiers from `gnus-list-identifiers`. 1145Valid values are nil, t, `head', `last', an integer or a predicate. 1146See Info node `(gnus)Customizing Articles' for details." 1147 :version "21.1" 1148 :group 'gnus-article-treat 1149 :link '(custom-manual "(gnus)Customizing Articles") 1150 :type gnus-article-treat-custom) 1151 1152(make-obsolete-variable 'gnus-treat-strip-pgp 1153 "This option is obsolete in Gnus 5.10.") 1154 1155(defcustom gnus-treat-strip-pem nil 1156 "Strip PEM signatures. 1157Valid values are nil, t, `head', `last', an integer or a predicate. 1158See Info node `(gnus)Customizing Articles' for details." 1159 :group 'gnus-article-treat 1160 :link '(custom-manual "(gnus)Customizing Articles") 1161 :type gnus-article-treat-custom) 1162 1163(defcustom gnus-treat-strip-banner t 1164 "Strip banners from articles. 1165The banner to be stripped is specified in the `banner' group parameter. 1166Valid values are nil, t, `head', `last', an integer or a predicate. 1167See Info node `(gnus)Customizing Articles' for details." 1168 :group 'gnus-article-treat 1169 :link '(custom-manual "(gnus)Customizing Articles") 1170 :type gnus-article-treat-custom) 1171 1172(defcustom gnus-treat-highlight-headers 'head 1173 "Highlight the headers. 1174Valid values are nil, t, `head', `last', an integer or a predicate. 1175See Info node `(gnus)Customizing Articles' for details." 1176 :group 'gnus-article-treat 1177 :link '(custom-manual "(gnus)Customizing Articles") 1178 :type gnus-article-treat-head-custom) 1179(put 'gnus-treat-highlight-headers 'highlight t) 1180 1181(defcustom gnus-treat-highlight-citation t 1182 "Highlight cited text. 1183Valid values are nil, t, `head', `last', an integer or a predicate. 1184See Info node `(gnus)Customizing Articles' for details." 1185 :group 'gnus-article-treat 1186 :link '(custom-manual "(gnus)Customizing Articles") 1187 :type gnus-article-treat-custom) 1188(put 'gnus-treat-highlight-citation 'highlight t) 1189 1190(defcustom gnus-treat-date-ut nil 1191 "Display the Date in UT (GMT). 1192Valid values are nil, t, `head', `last', an integer or a predicate. 1193See Info node `(gnus)Customizing Articles' for details." 1194 :group 'gnus-article-treat 1195 :link '(custom-manual "(gnus)Customizing Articles") 1196 :type gnus-article-treat-head-custom) 1197 1198(defcustom gnus-treat-date-local nil 1199 "Display the Date in the local timezone. 1200Valid values are nil, t, `head', `last', an integer or a predicate. 1201See Info node `(gnus)Customizing Articles' for details." 1202 :group 'gnus-article-treat 1203 :link '(custom-manual "(gnus)Customizing Articles") 1204 :type gnus-article-treat-head-custom) 1205 1206(defcustom gnus-treat-date-english nil 1207 "Display the Date in a format that can be read aloud in English. 1208Valid values are nil, t, `head', `last', an integer or a predicate. 1209See Info node `(gnus)Customizing Articles' for details." 1210 :version "22.1" 1211 :group 'gnus-article-treat 1212 :link '(custom-manual "(gnus)Customizing Articles") 1213 :type gnus-article-treat-head-custom) 1214 1215(defcustom gnus-treat-date-lapsed nil 1216 "Display the Date header in a way that says how much time has elapsed. 1217Valid values are nil, t, `head', `last', an integer or a predicate. 1218See Info node `(gnus)Customizing Articles' for details." 1219 :group 'gnus-article-treat 1220 :link '(custom-manual "(gnus)Customizing Articles") 1221 :type gnus-article-treat-head-custom) 1222 1223(defcustom gnus-treat-date-original nil 1224 "Display the date in the original timezone. 1225Valid values are nil, t, `head', `last', an integer or a predicate. 1226See Info node `(gnus)Customizing Articles' for details." 1227 :group 'gnus-article-treat 1228 :link '(custom-manual "(gnus)Customizing Articles") 1229 :type gnus-article-treat-head-custom) 1230 1231(defcustom gnus-treat-date-iso8601 nil 1232 "Display the date in the ISO8601 format. 1233Valid values are nil, t, `head', `last', an integer or a predicate. 1234See Info node `(gnus)Customizing Articles' for details." 1235 :version "21.1" 1236 :group 'gnus-article-treat 1237 :link '(custom-manual "(gnus)Customizing Articles") 1238 :type gnus-article-treat-head-custom) 1239 1240(defcustom gnus-treat-date-user-defined nil 1241 "Display the date in a user-defined format. 1242The format is defined by the `gnus-article-time-format' variable. 1243Valid values are nil, t, `head', `last', an integer or a predicate. 1244See Info node `(gnus)Customizing Articles' for details." 1245 :group 'gnus-article-treat 1246 :link '(custom-manual "(gnus)Customizing Articles") 1247 :type gnus-article-treat-head-custom) 1248 1249(defcustom gnus-treat-strip-headers-in-body t 1250 "Strip the X-No-Archive header line from the beginning of the body. 1251Valid values are nil, t, `head', `last', an integer or a predicate. 1252See Info node `(gnus)Customizing Articles' for details." 1253 :version "21.1" 1254 :group 'gnus-article-treat 1255 :link '(custom-manual "(gnus)Customizing Articles") 1256 :type gnus-article-treat-custom) 1257 1258(defcustom gnus-treat-strip-trailing-blank-lines nil 1259 "Strip trailing blank lines. 1260Valid values are nil, t, `head', `last', an integer or a predicate. 1261See Info node `(gnus)Customizing Articles' for details. 1262 1263When set to t, it also strips trailing blanks in all MIME parts. 1264Consider to use `last' instead." 1265 :group 'gnus-article-treat 1266 :link '(custom-manual "(gnus)Customizing Articles") 1267 :type gnus-article-treat-custom) 1268 1269(defcustom gnus-treat-strip-leading-blank-lines nil 1270 "Strip leading blank lines. 1271Valid values are nil, t, `head', `last', an integer or a predicate. 1272See Info node `(gnus)Customizing Articles' for details. 1273 1274When set to t, it also strips trailing blanks in all MIME parts." 1275 :group 'gnus-article-treat 1276 :link '(custom-manual "(gnus)Customizing Articles") 1277 :type gnus-article-treat-custom) 1278 1279(defcustom gnus-treat-strip-multiple-blank-lines nil 1280 "Strip multiple blank lines. 1281Valid values are nil, t, `head', `last', an integer or a predicate. 1282See Info node `(gnus)Customizing Articles' for details." 1283 :group 'gnus-article-treat 1284 :link '(custom-manual "(gnus)Customizing Articles") 1285 :type gnus-article-treat-custom) 1286 1287(defcustom gnus-treat-unfold-headers 'head 1288 "Unfold folded header lines. 1289Valid values are nil, t, `head', `last', an integer or a predicate. 1290See Info node `(gnus)Customizing Articles' for details." 1291 :version "22.1" 1292 :group 'gnus-article-treat 1293 :link '(custom-manual "(gnus)Customizing Articles") 1294 :type gnus-article-treat-custom) 1295 1296(defcustom gnus-treat-fold-headers nil 1297 "Fold headers. 1298Valid values are nil, t, `head', `last', an integer or a predicate. 1299See Info node `(gnus)Customizing Articles' for details." 1300 :version "22.1" 1301 :group 'gnus-article-treat 1302 :link '(custom-manual "(gnus)Customizing Articles") 1303 :type gnus-article-treat-custom) 1304 1305(defcustom gnus-treat-fold-newsgroups 'head 1306 "Fold the Newsgroups and Followup-To headers. 1307Valid values are nil, t, `head', `last', an integer or a predicate. 1308See Info node `(gnus)Customizing Articles' for details." 1309 :version "22.1" 1310 :group 'gnus-article-treat 1311 :link '(custom-manual "(gnus)Customizing Articles") 1312 :type gnus-article-treat-custom) 1313 1314(defcustom gnus-treat-overstrike t 1315 "Treat overstrike highlighting. 1316Valid values are nil, t, `head', `last', an integer or a predicate. 1317See Info node `(gnus)Customizing Articles' for details." 1318 :group 'gnus-article-treat 1319 :link '(custom-manual "(gnus)Customizing Articles") 1320 :type gnus-article-treat-custom) 1321(put 'gnus-treat-overstrike 'highlight t) 1322 1323(make-obsolete-variable 'gnus-treat-display-xface 1324 'gnus-treat-display-x-face) 1325 1326(defcustom gnus-treat-display-x-face 1327 (and (not noninteractive) 1328 (gnus-image-type-available-p 'xbm) 1329 (if (featurep 'xemacs) 1330 (featurep 'xface) 1331 (and (string-match "^0x" (shell-command-to-string "uncompface")) 1332 (executable-find "icontopbm"))) 1333 'head) 1334 "Display X-Face headers. 1335Valid values are nil and `head'. 1336See Info node `(gnus)Customizing Articles' and Info node 1337`(gnus)X-Face' for details." 1338 :group 'gnus-article-treat 1339 :version "21.1" 1340 :link '(custom-manual "(gnus)Customizing Articles") 1341 :link '(custom-manual "(gnus)X-Face") 1342 :type gnus-article-treat-head-custom 1343 :set (lambda (symbol value) 1344 (set-default 1345 symbol 1346 (cond ((or (boundp symbol) (get symbol 'saved-value)) 1347 value) 1348 ((boundp 'gnus-treat-display-xface) 1349 (message "\ 1350** gnus-treat-display-xface is an obsolete variable;\ 1351 use gnus-treat-display-x-face instead") 1352 (default-value 'gnus-treat-display-xface)) 1353 ((get 'gnus-treat-display-xface 'saved-value) 1354 (message "\ 1355** gnus-treat-display-xface is an obsolete variable;\ 1356 use gnus-treat-display-x-face instead") 1357 (eval (car (get 'gnus-treat-display-xface 'saved-value)))) 1358 (t 1359 value))))) 1360(put 'gnus-treat-display-x-face 'highlight t) 1361 1362(defcustom gnus-treat-display-face 1363 (and (not noninteractive) 1364 (gnus-image-type-available-p 'png) 1365 'head) 1366 "Display Face headers. 1367Valid values are nil, t, `head', `last', an integer or a predicate. 1368See Info node `(gnus)Customizing Articles' and Info node 1369`(gnus)X-Face' for details." 1370 :group 'gnus-article-treat 1371 :version "22.1" 1372 :link '(custom-manual "(gnus)Customizing Articles") 1373 :link '(custom-manual "(gnus)X-Face") 1374 :type gnus-article-treat-head-custom) 1375(put 'gnus-treat-display-face 'highlight t) 1376 1377(defcustom gnus-treat-display-smileys (gnus-image-type-available-p 'xpm) 1378 "Display smileys. 1379Valid values are nil, t, `head', `last', an integer or a predicate. 1380See Info node `(gnus)Customizing Articles' and Info node 1381`(gnus)Smileys' for details." 1382 :group 'gnus-article-treat 1383 :version "21.1" 1384 :link '(custom-manual "(gnus)Customizing Articles") 1385 :link '(custom-manual "(gnus)Smileys") 1386 :type gnus-article-treat-custom) 1387(put 'gnus-treat-display-smileys 'highlight t) 1388 1389(defcustom gnus-treat-from-picon 1390 (if (and (gnus-image-type-available-p 'xpm) 1391 (gnus-picons-installed-p)) 1392 'head nil) 1393 "Display picons in the From header. 1394Valid values are nil, t, `head', `last', an integer or a predicate. 1395See Info node `(gnus)Customizing Articles' and Info node 1396`(gnus)Picons' for details." 1397 :version "22.1" 1398 :group 'gnus-article-treat 1399 :group 'gnus-picon 1400 :link '(custom-manual "(gnus)Customizing Articles") 1401 :link '(custom-manual "(gnus)Picons") 1402 :type gnus-article-treat-head-custom) 1403(put 'gnus-treat-from-picon 'highlight t) 1404 1405(defcustom gnus-treat-mail-picon 1406 (if (and (gnus-image-type-available-p 'xpm) 1407 (gnus-picons-installed-p)) 1408 'head nil) 1409 "Display picons in To and Cc headers. 1410Valid values are nil, t, `head', `last', an integer or a predicate. 1411See Info node `(gnus)Customizing Articles' and Info node 1412`(gnus)Picons' for details." 1413 :version "22.1" 1414 :group 'gnus-article-treat 1415 :group 'gnus-picon 1416 :link '(custom-manual "(gnus)Customizing Articles") 1417 :link '(custom-manual "(gnus)Picons") 1418 :type gnus-article-treat-head-custom) 1419(put 'gnus-treat-mail-picon 'highlight t) 1420 1421(defcustom gnus-treat-newsgroups-picon 1422 (if (and (gnus-image-type-available-p 'xpm) 1423 (gnus-picons-installed-p)) 1424 'head nil) 1425 "Display picons in the Newsgroups and Followup-To headers. 1426Valid values are nil, t, `head', `last', an integer or a predicate. 1427See Info node `(gnus)Customizing Articles' and Info node 1428`(gnus)Picons' for details." 1429 :version "22.1" 1430 :group 'gnus-article-treat 1431 :group 'gnus-picon 1432 :link '(custom-manual "(gnus)Customizing Articles") 1433 :link '(custom-manual "(gnus)Picons") 1434 :type gnus-article-treat-head-custom) 1435(put 'gnus-treat-newsgroups-picon 'highlight t) 1436 1437(defcustom gnus-treat-body-boundary 1438 (if (or gnus-treat-newsgroups-picon 1439 gnus-treat-mail-picon 1440 gnus-treat-from-picon) 1441 'head nil) 1442 "Draw a boundary at the end of the headers. 1443Valid values are nil and `head'. 1444See Info node `(gnus)Customizing Articles' for details." 1445 :version "22.1" 1446 :group 'gnus-article-treat 1447 :link '(custom-manual "(gnus)Customizing Articles") 1448 :type gnus-article-treat-head-custom) 1449 1450(defcustom gnus-treat-capitalize-sentences nil 1451 "Capitalize sentence-starting words. 1452Valid values are nil, t, `head', `last', an integer or a predicate. 1453See Info node `(gnus)Customizing Articles' for details." 1454 :version "21.1" 1455 :group 'gnus-article-treat 1456 :link '(custom-manual "(gnus)Customizing Articles") 1457 :type gnus-article-treat-custom) 1458 1459(defcustom gnus-treat-wash-html nil 1460 "Format as HTML. 1461Valid values are nil, t, `head', `last', an integer or a predicate. 1462See Info node `(gnus)Customizing Articles' for details." 1463 :version "22.1" 1464 :group 'gnus-article-treat 1465 :link '(custom-manual "(gnus)Customizing Articles") 1466 :type gnus-article-treat-custom) 1467 1468(defcustom gnus-treat-fill-long-lines nil 1469 "Fill long lines. 1470Valid values are nil, t, `head', `last', an integer or a predicate. 1471See Info node `(gnus)Customizing Articles' for details." 1472 :group 'gnus-article-treat 1473 :link '(custom-manual "(gnus)Customizing Articles") 1474 :type gnus-article-treat-custom) 1475 1476(defcustom gnus-treat-play-sounds nil 1477 "Play sounds. 1478Valid values are nil, t, `head', `last', an integer or a predicate. 1479See Info node `(gnus)Customizing Articles' for details." 1480 :version "21.1" 1481 :group 'gnus-article-treat 1482 :link '(custom-manual "(gnus)Customizing Articles") 1483 :type gnus-article-treat-custom) 1484 1485(defcustom gnus-treat-translate nil 1486 "Translate articles from one language to another. 1487Valid values are nil, t, `head', `last', an integer or a predicate. 1488See Info node `(gnus)Customizing Articles' for details." 1489 :version "21.1" 1490 :group 'gnus-article-treat 1491 :link '(custom-manual "(gnus)Customizing Articles") 1492 :type gnus-article-treat-custom) 1493 1494(defcustom gnus-treat-x-pgp-sig nil 1495 "Verify X-PGP-Sig. 1496To automatically treat X-PGP-Sig, set it to head. 1497Valid values are nil, t, `head', `last', an integer or a predicate. 1498See Info node `(gnus)Customizing Articles' for details." 1499 :version "22.1" 1500 :group 'gnus-article-treat 1501 :group 'mime-security 1502 :link '(custom-manual "(gnus)Customizing Articles") 1503 :type gnus-article-treat-custom) 1504 1505(defvar gnus-article-encrypt-protocol-alist 1506 '(("PGP" . mml2015-self-encrypt))) 1507 1508;; Set to nil if more than one protocol added to 1509;; gnus-article-encrypt-protocol-alist. 1510(defcustom gnus-article-encrypt-protocol "PGP" 1511 "The protocol used for encrypt articles. 1512It is a string, such as \"PGP\". If nil, ask user." 1513 :version "22.1" 1514 :type 'string 1515 :group 'mime-security) 1516 1517(defvar gnus-article-wash-function nil 1518 "Function used for converting HTML into text.") 1519 1520(defcustom gnus-use-idna (and (condition-case nil (require 'idna) (file-error)) 1521 (mm-coding-system-p 'utf-8) 1522 (executable-find idna-program)) 1523 "Whether IDNA decoding of headers is used when viewing messages. 1524This requires GNU Libidn, and by default only enabled if it is found." 1525 :version "22.1" 1526 :group 'gnus-article-headers 1527 :type 'boolean) 1528 1529(defcustom gnus-article-over-scroll nil 1530 "If non-nil, allow scrolling the article buffer even when there no more text." 1531 :version "22.1" 1532 :group 'gnus-article 1533 :type 'boolean) 1534 1535;;; Internal variables 1536 1537(defvar gnus-english-month-names 1538 '("January" "February" "March" "April" "May" "June" "July" "August" 1539 "September" "October" "November" "December")) 1540 1541(defvar article-goto-body-goes-to-point-min-p nil) 1542(defvar gnus-article-wash-types nil) 1543(defvar gnus-article-emphasis-alist nil) 1544(defvar gnus-article-image-alist nil) 1545 1546(defvar gnus-article-mime-handle-alist-1 nil) 1547(defvar gnus-treatment-function-alist 1548 '((gnus-treat-x-pgp-sig gnus-article-verify-x-pgp-sig) 1549 (gnus-treat-strip-banner gnus-article-strip-banner) 1550 (gnus-treat-strip-headers-in-body gnus-article-strip-headers-in-body) 1551 (gnus-treat-highlight-signature gnus-article-highlight-signature) 1552 (gnus-treat-buttonize gnus-article-add-buttons) 1553 (gnus-treat-fill-article gnus-article-fill-cited-article) 1554 (gnus-treat-fill-long-lines gnus-article-fill-long-lines) 1555 (gnus-treat-strip-cr gnus-article-remove-cr) 1556 (gnus-treat-unsplit-urls gnus-article-unsplit-urls) 1557 (gnus-treat-date-ut gnus-article-date-ut) 1558 (gnus-treat-date-local gnus-article-date-local) 1559 (gnus-treat-date-english gnus-article-date-english) 1560 (gnus-treat-date-original gnus-article-date-original) 1561 (gnus-treat-date-user-defined gnus-article-date-user) 1562 (gnus-treat-date-iso8601 gnus-article-date-iso8601) 1563 (gnus-treat-date-lapsed gnus-article-date-lapsed) 1564 (gnus-treat-display-x-face gnus-article-display-x-face) 1565 (gnus-treat-display-face gnus-article-display-face) 1566 (gnus-treat-hide-headers gnus-article-maybe-hide-headers) 1567 (gnus-treat-hide-boring-headers gnus-article-hide-boring-headers) 1568 (gnus-treat-hide-signature gnus-article-hide-signature) 1569 (gnus-treat-strip-list-identifiers gnus-article-hide-list-identifiers) 1570 (gnus-treat-leading-whitespace gnus-article-remove-leading-whitespace) 1571 (gnus-treat-strip-pem gnus-article-hide-pem) 1572 (gnus-treat-from-picon gnus-treat-from-picon) 1573 (gnus-treat-mail-picon gnus-treat-mail-picon) 1574 (gnus-treat-newsgroups-picon gnus-treat-newsgroups-picon) 1575 (gnus-treat-highlight-headers gnus-article-highlight-headers) 1576 (gnus-treat-highlight-signature gnus-article-highlight-signature) 1577 (gnus-treat-strip-trailing-blank-lines 1578 gnus-article-remove-trailing-blank-lines) 1579 (gnus-treat-strip-leading-blank-lines 1580 gnus-article-strip-leading-blank-lines) 1581 (gnus-treat-strip-multiple-blank-lines 1582 gnus-article-strip-multiple-blank-lines) 1583 (gnus-treat-overstrike gnus-article-treat-overstrike) 1584 (gnus-treat-unfold-headers gnus-article-treat-unfold-headers) 1585 (gnus-treat-fold-headers gnus-article-treat-fold-headers) 1586 (gnus-treat-fold-newsgroups gnus-article-treat-fold-newsgroups) 1587 (gnus-treat-buttonize-head gnus-article-add-buttons-to-head) 1588 (gnus-treat-display-smileys gnus-treat-smiley) 1589 (gnus-treat-capitalize-sentences gnus-article-capitalize-sentences) 1590 (gnus-treat-wash-html gnus-article-wash-html) 1591 (gnus-treat-emphasize gnus-article-emphasize) 1592 (gnus-treat-hide-citation gnus-article-hide-citation) 1593 (gnus-treat-hide-citation-maybe gnus-article-hide-citation-maybe) 1594 (gnus-treat-highlight-citation gnus-article-highlight-citation) 1595 (gnus-treat-body-boundary gnus-article-treat-body-boundary) 1596 (gnus-treat-play-sounds gnus-earcon-display))) 1597 1598(defvar gnus-article-mime-handle-alist nil) 1599(defvar article-lapsed-timer nil) 1600(defvar gnus-article-current-summary nil) 1601 1602(defvar gnus-article-mode-syntax-table 1603 (let ((table (copy-syntax-table text-mode-syntax-table))) 1604 ;; This causes the citation match run O(2^n). 1605 ;; (modify-syntax-entry ?- "w" table) 1606 (modify-syntax-entry ?> ")<" table) 1607 (modify-syntax-entry ?< "(>" table) 1608 ;; make M-. in article buffers work for `foo' strings 1609 (modify-syntax-entry ?' " " table) 1610 (modify-syntax-entry ?` " " table) 1611 table) 1612 "Syntax table used in article mode buffers. 1613Initialized from `text-mode-syntax-table.") 1614 1615(defvar gnus-save-article-buffer nil) 1616 1617(defvar gnus-article-mode-line-format-alist 1618 (nconc '((?w (gnus-article-wash-status) ?s) 1619 (?m (gnus-article-mime-part-status) ?s)) 1620 gnus-summary-mode-line-format-alist)) 1621 1622(defvar gnus-number-of-articles-to-be-saved nil) 1623 1624(defvar gnus-inhibit-hiding nil) 1625 1626(defvar gnus-article-edit-mode nil) 1627 1628;;; Macros for dealing with the article buffer. 1629 1630(defmacro gnus-with-article-headers (&rest forms) 1631 `(save-excursion 1632 (set-buffer gnus-article-buffer) 1633 (save-restriction 1634 (let ((inhibit-read-only t) 1635 (inhibit-point-motion-hooks t) 1636 (case-fold-search t)) 1637 (article-narrow-to-head) 1638 ,@forms)))) 1639 1640(put 'gnus-with-article-headers 'lisp-indent-function 0) 1641(put 'gnus-with-article-headers 'edebug-form-spec '(body)) 1642 1643(defmacro gnus-with-article-buffer (&rest forms) 1644 `(save-excursion 1645 (set-buffer gnus-article-buffer) 1646 (let ((inhibit-read-only t)) 1647 ,@forms))) 1648 1649(put 'gnus-with-article-buffer 'lisp-indent-function 0) 1650(put 'gnus-with-article-buffer 'edebug-form-spec '(body)) 1651 1652(defun gnus-article-goto-header (header) 1653 "Go to HEADER, which is a regular expression." 1654 (re-search-forward (concat "^\\(" header "\\):") nil t)) 1655 1656(defsubst gnus-article-hide-text (b e props) 1657 "Set text PROPS on the B to E region, extending `intangible' 1 past B." 1658 (gnus-add-text-properties-when 'article-type nil b e props) 1659 (when (memq 'intangible props) 1660 (put-text-property 1661 (max (1- b) (point-min)) 1662 b 'intangible (cddr (memq 'intangible props))))) 1663 1664(defsubst gnus-article-unhide-text (b e) 1665 "Remove hidden text properties from region between B and E." 1666 (remove-text-properties b e gnus-hidden-properties) 1667 (when (memq 'intangible gnus-hidden-properties) 1668 (put-text-property (max (1- b) (point-min)) 1669 b 'intangible nil))) 1670 1671(defun gnus-article-hide-text-type (b e type) 1672 "Hide text of TYPE between B and E." 1673 (gnus-add-wash-type type) 1674 (gnus-article-hide-text 1675 b e (cons 'article-type (cons type gnus-hidden-properties)))) 1676 1677(defun gnus-article-unhide-text-type (b e type) 1678 "Unhide text of TYPE between B and E." 1679 (gnus-delete-wash-type type) 1680 (remove-text-properties 1681 b e (cons 'article-type (cons type gnus-hidden-properties))) 1682 (when (memq 'intangible gnus-hidden-properties) 1683 (put-text-property (max (1- b) (point-min)) 1684 b 'intangible nil))) 1685 1686(defun gnus-article-hide-text-of-type (type) 1687 "Hide text of TYPE in the current buffer." 1688 (save-excursion 1689 (let ((b (point-min)) 1690 (e (point-max))) 1691 (while (setq b (text-property-any b e 'article-type type)) 1692 (add-text-properties b (incf b) gnus-hidden-properties))))) 1693 1694(defun gnus-article-delete-text-of-type (type) 1695 "Delete text of TYPE in the current buffer." 1696 (save-excursion 1697 (let ((b (point-min))) 1698 (if (eq type 'multipart) 1699 ;; Remove MIME buttons associated with multipart/alternative parts. 1700 (progn 1701 (goto-char b) 1702 (while (if (get-text-property (point) 'gnus-part) 1703 (setq b (point)) 1704 (when (setq b (next-single-property-change (point) 1705 'gnus-part)) 1706 (goto-char b) 1707 t)) 1708 (end-of-line) 1709 (skip-chars-forward "\n") 1710 (when (eq (get-text-property b 'article-type) 'multipart) 1711 (delete-region b (point))))) 1712 (while (setq b (text-property-any b (point-max) 'article-type type)) 1713 (delete-region 1714 b (or (text-property-not-all b (point-max) 'article-type type) 1715 (point-max)))))))) 1716 1717(defun gnus-article-delete-invisible-text () 1718 "Delete all invisible text in the current buffer." 1719 (save-excursion 1720 (let ((b (point-min))) 1721 (while (setq b (text-property-any b (point-max) 'invisible t)) 1722 (delete-region 1723 b (or (text-property-not-all b (point-max) 'invisible t) 1724 (point-max))))))) 1725 1726(defun gnus-article-text-type-exists-p (type) 1727 "Say whether any text of type TYPE exists in the buffer." 1728 (text-property-any (point-min) (point-max) 'article-type type)) 1729 1730(defsubst gnus-article-header-rank () 1731 "Give the rank of the string HEADER as given by `gnus-sorted-header-list'." 1732 (let ((list gnus-sorted-header-list) 1733 (i 1)) 1734 (while list 1735 (if (looking-at (car list)) 1736 (setq list nil) 1737 (setq list (cdr list)) 1738 (incf i))) 1739 i)) 1740 1741(defun article-hide-headers (&optional arg delete) 1742 "Hide unwanted headers and possibly sort them as well." 1743 (interactive) 1744 ;; This function might be inhibited. 1745 (unless gnus-inhibit-hiding 1746 (let ((inhibit-read-only nil) 1747 (case-fold-search t) 1748 (max (1+ (length gnus-sorted-header-list))) 1749 (inhibit-point-motion-hooks t) 1750 (cur (current-buffer)) 1751 ignored visible beg) 1752 (save-excursion 1753 ;; `gnus-ignored-headers' and `gnus-visible-headers' may be 1754 ;; group parameters, so we should go to the summary buffer. 1755 (when (prog1 1756 (condition-case nil 1757 (progn (set-buffer gnus-summary-buffer) t) 1758 (error nil)) 1759 (setq ignored (when (not gnus-visible-headers) 1760 (cond ((stringp gnus-ignored-headers) 1761 gnus-ignored-headers) 1762 ((listp gnus-ignored-headers) 1763 (mapconcat 'identity 1764 gnus-ignored-headers 1765 "\\|")))) 1766 visible (cond ((stringp gnus-visible-headers) 1767 gnus-visible-headers) 1768 ((and gnus-visible-headers 1769 (listp gnus-visible-headers)) 1770 (mapconcat 'identity 1771 gnus-visible-headers 1772 "\\|"))))) 1773 (set-buffer cur)) 1774 (save-restriction 1775 ;; First we narrow to just the headers. 1776 (article-narrow-to-head) 1777 ;; Hide any "From " lines at the beginning of (mail) articles. 1778 (while (looking-at "From ") 1779 (forward-line 1)) 1780 (unless (bobp) 1781 (delete-region (point-min) (point))) 1782 ;; Then treat the rest of the header lines. 1783 ;; Then we use the two regular expressions 1784 ;; `gnus-ignored-headers' and `gnus-visible-headers' to 1785 ;; select which header lines is to remain visible in the 1786 ;; article buffer. 1787 (while (re-search-forward "^[^ \t:]*:" nil t) 1788 (beginning-of-line) 1789 ;; Mark the rank of the header. 1790 (put-text-property 1791 (point) (1+ (point)) 'message-rank 1792 (if (or (and visible (looking-at visible)) 1793 (and ignored 1794 (not (looking-at ignored)))) 1795 (gnus-article-header-rank) 1796 (+ 2 max))) 1797 (forward-line 1)) 1798 (message-sort-headers-1) 1799 (when (setq beg (text-property-any 1800 (point-min) (point-max) 'message-rank (+ 2 max))) 1801 ;; We delete the unwanted headers. 1802 (gnus-add-wash-type 'headers) 1803 (add-text-properties (point-min) (+ 5 (point-min)) 1804 '(article-type headers dummy-invisible t)) 1805 (delete-region beg (point-max)))))))) 1806 1807(defun article-hide-boring-headers (&optional arg) 1808 "Toggle hiding of headers that aren't very interesting. 1809If given a negative prefix, always show; if given a positive prefix, 1810always hide." 1811 (interactive (gnus-article-hidden-arg)) 1812 (when (and (not (gnus-article-check-hidden-text 'boring-headers arg)) 1813 (not gnus-show-all-headers)) 1814 (save-excursion 1815 (save-restriction 1816 (let ((inhibit-read-only t) 1817 (list gnus-boring-article-headers) 1818 (inhibit-point-motion-hooks t) 1819 elem) 1820 (article-narrow-to-head) 1821 (while list 1822 (setq elem (pop list)) 1823 (goto-char (point-min)) 1824 (cond 1825 ;; Hide empty headers. 1826 ((eq elem 'empty) 1827 (while (re-search-forward "^[^: \t]+:[ \t]*\n[^ \t]" nil t) 1828 (forward-line -1) 1829 (gnus-article-hide-text-type 1830 (gnus-point-at-bol) 1831 (progn 1832 (end-of-line) 1833 (if (re-search-forward "^[^ \t]" nil t) 1834 (match-beginning 0) 1835 (point-max))) 1836 'boring-headers))) 1837 ;; Hide boring Newsgroups header. 1838 ((eq elem 'newsgroups) 1839 (when (gnus-string-equal 1840 (gnus-fetch-field "newsgroups") 1841 (gnus-group-real-name 1842 (if (boundp 'gnus-newsgroup-name) 1843 gnus-newsgroup-name 1844 ""))) 1845 (gnus-article-hide-header "newsgroups"))) 1846 ((eq elem 'to-address) 1847 (let ((to (message-fetch-field "to")) 1848 (to-address 1849 (gnus-parameter-to-address 1850 (if (boundp 'gnus-newsgroup-name) 1851 gnus-newsgroup-name "")))) 1852 (when (and to to-address 1853 (ignore-errors 1854 (gnus-string-equal 1855 ;; only one address in To 1856 (nth 1 (mail-extract-address-components to)) 1857 to-address))) 1858 (gnus-article-hide-header "to")))) 1859 ((eq elem 'to-list) 1860 (let ((to (message-fetch-field "to")) 1861 (to-list 1862 (gnus-parameter-to-list 1863 (if (boundp 'gnus-newsgroup-name) 1864 gnus-newsgroup-name "")))) 1865 (when (and to to-list 1866 (ignore-errors 1867 (gnus-string-equal 1868 ;; only one address in To 1869 (nth 1 (mail-extract-address-components to)) 1870 to-list))) 1871 (gnus-article-hide-header "to")))) 1872 ((eq elem 'cc-list) 1873 (let ((cc (message-fetch-field "cc")) 1874 (to-list 1875 (gnus-parameter-to-list 1876 (if (boundp 'gnus-newsgroup-name) 1877 gnus-newsgroup-name "")))) 1878 (when (and cc to-list 1879 (ignore-errors 1880 (gnus-string-equal 1881 ;; only one address in CC 1882 (nth 1 (mail-extract-address-components cc)) 1883 to-list))) 1884 (gnus-article-hide-header "cc")))) 1885 ((eq elem 'followup-to) 1886 (when (gnus-string-equal 1887 (message-fetch-field "followup-to") 1888 (message-fetch-field "newsgroups")) 1889 (gnus-article-hide-header "followup-to"))) 1890 ((eq elem 'reply-to) 1891 (if (gnus-group-find-parameter 1892 gnus-newsgroup-name 'broken-reply-to) 1893 (gnus-article-hide-header "reply-to") 1894 (let ((from (message-fetch-field "from")) 1895 (reply-to (message-fetch-field "reply-to"))) 1896 (when 1897 (and 1898 from reply-to 1899 (ignore-errors 1900 (equal 1901 (sort (mapcar 1902 (lambda (x) (downcase (cadr x))) 1903 (mail-extract-address-components from t)) 1904 'string<) 1905 (sort (mapcar 1906 (lambda (x) (downcase (cadr x))) 1907 (mail-extract-address-components reply-to t)) 1908 'string<)))) 1909 (gnus-article-hide-header "reply-to"))))) 1910 ((eq elem 'date) 1911 (let ((date (with-current-buffer gnus-original-article-buffer 1912 ;; If date in `gnus-article-buffer' is localized 1913 ;; (`gnus-treat-date-user-defined'), 1914 ;; `days-between' might fail. 1915 (message-fetch-field "date")))) 1916 (when (and date 1917 (< (days-between (current-time-string) date) 1918 4)) 1919 (gnus-article-hide-header "date")))) 1920 ((eq elem 'long-to) 1921 (let ((to (message-fetch-field "to")) 1922 (cc (message-fetch-field "cc"))) 1923 (when (> (length to) 1024) 1924 (gnus-article-hide-header "to")) 1925 (when (> (length cc) 1024) 1926 (gnus-article-hide-header "cc")))) 1927 ((eq elem 'many-to) 1928 (let ((to-count 0) 1929 (cc-count 0)) 1930 (goto-char (point-min)) 1931 (while (re-search-forward "^to:" nil t) 1932 (setq to-count (1+ to-count))) 1933 (when (> to-count 1) 1934 (while (> to-count 0) 1935 (goto-char (point-min)) 1936 (save-restriction 1937 (re-search-forward "^to:" nil nil to-count) 1938 (forward-line -1) 1939 (narrow-to-region (point) (point-max)) 1940 (gnus-article-hide-header "to")) 1941 (setq to-count (1- to-count)))) 1942 (goto-char (point-min)) 1943 (while (re-search-forward "^cc:" nil t) 1944 (setq cc-count (1+ cc-count))) 1945 (when (> cc-count 1) 1946 (while (> cc-count 0) 1947 (goto-char (point-min)) 1948 (save-restriction 1949 (re-search-forward "^cc:" nil nil cc-count) 1950 (forward-line -1) 1951 (narrow-to-region (point) (point-max)) 1952 (gnus-article-hide-header "cc")) 1953 (setq cc-count (1- cc-count))))))))))))) 1954 1955(defun gnus-article-hide-header (header) 1956 (save-excursion 1957 (goto-char (point-min)) 1958 (when (re-search-forward (concat "^" header ":") nil t) 1959 (gnus-article-hide-text-type 1960 (gnus-point-at-bol) 1961 (progn 1962 (end-of-line) 1963 (if (re-search-forward "^[^ \t]" nil t) 1964 (match-beginning 0) 1965 (point-max))) 1966 'boring-headers)))) 1967 1968(defvar gnus-article-normalized-header-length 40 1969 "Length of normalized headers.") 1970 1971(defun article-normalize-headers () 1972 "Make all header lines 40 characters long." 1973 (interactive) 1974 (let ((inhibit-read-only t) 1975 column) 1976 (save-excursion 1977 (save-restriction 1978 (article-narrow-to-head) 1979 (while (not (eobp)) 1980 (cond 1981 ((< (setq column (- (gnus-point-at-eol) (point))) 1982 gnus-article-normalized-header-length) 1983 (end-of-line) 1984 (insert (make-string 1985 (- gnus-article-normalized-header-length column) 1986 ? ))) 1987 ((> column gnus-article-normalized-header-length) 1988 (gnus-put-text-property 1989 (progn 1990 (forward-char gnus-article-normalized-header-length) 1991 (point)) 1992 (gnus-point-at-eol) 1993 'invisible t)) 1994 (t 1995 ;; Do nothing. 1996 )) 1997 (forward-line 1)))))) 1998 1999(defun article-treat-dumbquotes () 2000 "Translate M****s*** sm*rtq**t*s and other symbols into proper text. 2001Note that this function guesses whether a character is a sm*rtq**t* or 2002not, so it should only be used interactively. 2003 2004Sm*rtq**t*s are M****s***'s unilateral extension to the 2005iso-8859-1 character map in an attempt to provide more quoting 2006characters. If you see something like \\222 or \\264 where 2007you're expecting some kind of apostrophe or quotation mark, then 2008try this wash." 2009 (interactive) 2010 (article-translate-strings gnus-article-dumbquotes-map)) 2011 2012(defun article-translate-characters (from to) 2013 "Translate all characters in the body of the article according to FROM and TO. 2014FROM is a string of characters to translate from; to is a string of 2015characters to translate to." 2016 (save-excursion 2017 (when (article-goto-body) 2018 (let ((inhibit-read-only t) 2019 (x (make-string 225 ?x)) 2020 (i -1)) 2021 (while (< (incf i) (length x)) 2022 (aset x i i)) 2023 (setq i 0) 2024 (while (< i (length from)) 2025 (aset x (aref from i) (aref to i)) 2026 (incf i)) 2027 (translate-region (point) (point-max) x))))) 2028 2029(defun article-translate-strings (map) 2030 "Translate all string in the body of the article according to MAP. 2031MAP is an alist where the elements are on the form (\"from\" \"to\")." 2032 (save-excursion 2033 (when (article-goto-body) 2034 (let ((inhibit-read-only t) 2035 elem) 2036 (while (setq elem (pop map)) 2037 (save-excursion 2038 (while (search-forward (car elem) nil t) 2039 (replace-match (cadr elem))))))))) 2040 2041(defun article-treat-overstrike () 2042 "Translate overstrikes into bold text." 2043 (interactive) 2044 (save-excursion 2045 (when (article-goto-body) 2046 (let ((inhibit-read-only t)) 2047 (while (search-forward "\b" nil t) 2048 (let ((next (char-after)) 2049 (previous (char-after (- (point) 2)))) 2050 ;; We do the boldification/underlining by hiding the 2051 ;; overstrikes and putting the proper text property 2052 ;; on the letters. 2053 (cond 2054 ((eq next previous) 2055 (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike) 2056 (put-text-property (point) (1+ (point)) 'face 'bold)) 2057 ((eq next ?_) 2058 (gnus-article-hide-text-type 2059 (1- (point)) (1+ (point)) 'overstrike) 2060 (put-text-property 2061 (- (point) 2) (1- (point)) 'face 'underline)) 2062 ((eq previous ?_) 2063 (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike) 2064 (put-text-property 2065 (point) (1+ (point)) 'face 'underline))))))))) 2066 2067(defun gnus-article-treat-unfold-headers () 2068 "Unfold folded message headers. 2069Only the headers that fit into the current window width will be 2070unfolded." 2071 (interactive) 2072 (gnus-with-article-headers 2073 (let (length) 2074 (while (not (eobp)) 2075 (save-restriction 2076 (mail-header-narrow-to-field) 2077 (let ((header (buffer-string))) 2078 (with-temp-buffer 2079 (insert header) 2080 (goto-char (point-min)) 2081 (while (re-search-forward "\n[\t ]" nil t) 2082 (replace-match " " t t))) 2083 (setq length (- (point-max) (point-min) 1))) 2084 (when (< length (window-width)) 2085 (while (re-search-forward "\n[\t ]" nil t) 2086 (replace-match " " t t))) 2087 (goto-char (point-max))))))) 2088 2089(defun gnus-article-treat-fold-headers () 2090 "Fold message headers." 2091 (interactive) 2092 (gnus-with-article-headers 2093 (while (not (eobp)) 2094 (save-restriction 2095 (mail-header-narrow-to-field) 2096 (mail-header-fold-field) 2097 (goto-char (point-max)))))) 2098 2099(defun gnus-treat-smiley () 2100 "Toggle display of textual emoticons (\"smileys\") as small graphical icons." 2101 (interactive) 2102 (gnus-with-article-buffer 2103 (if (memq 'smiley gnus-article-wash-types) 2104 (gnus-delete-images 'smiley) 2105 (article-goto-body) 2106 (let ((images (smiley-region (point) (point-max)))) 2107 (when images 2108 (gnus-add-wash-type 'smiley) 2109 (dolist (image images) 2110 (gnus-add-image 'smiley image))))))) 2111 2112(defun gnus-article-remove-images () 2113 "Remove all images from the article buffer." 2114 (interactive) 2115 (gnus-with-article-buffer 2116 (dolist (elem gnus-article-image-alist) 2117 (gnus-delete-images (car elem))))) 2118 2119(defun gnus-article-treat-fold-newsgroups () 2120 "Unfold folded message headers. 2121Only the headers that fit into the current window width will be 2122unfolded." 2123 (interactive) 2124 (gnus-with-article-headers 2125 (while (gnus-article-goto-header "newsgroups\\|followup-to") 2126 (save-restriction 2127 (mail-header-narrow-to-field) 2128 (while (re-search-forward ", *" nil t) 2129 (replace-match ", " t t)) 2130 (mail-header-fold-field) 2131 (goto-char (point-max)))))) 2132 2133(defun gnus-article-treat-body-boundary () 2134 "Place a boundary line at the end of the headers." 2135 (interactive) 2136 (when (and gnus-body-boundary-delimiter 2137 (> (length gnus-body-boundary-delimiter) 0)) 2138 (gnus-with-article-headers 2139 (goto-char (point-max)) 2140 (let ((start (point))) 2141 (insert "X-Boundary: ") 2142 (gnus-add-text-properties start (point) '(invisible t intangible t)) 2143 (insert (let (str) 2144 (while (>= (1- (window-width)) (length str)) 2145 (setq str (concat str gnus-body-boundary-delimiter))) 2146 (substring str 0 (1- (window-width)))) 2147 "\n") 2148 (gnus-put-text-property start (point) 'gnus-decoration 'header))))) 2149 2150(defun article-fill-long-lines () 2151 "Fill lines that are wider than the window width." 2152 (interactive) 2153 (save-excursion 2154 (let ((inhibit-read-only t) 2155 (width (window-width (get-buffer-window (current-buffer))))) 2156 (save-restriction 2157 (article-goto-body) 2158 (let ((adaptive-fill-mode nil)) ;Why? -sm 2159 (while (not (eobp)) 2160 (end-of-line) 2161 (when (>= (current-column) (min fill-column width)) 2162 (narrow-to-region (min (1+ (point)) (point-max)) 2163 (gnus-point-at-bol)) 2164 (let ((goback (point-marker))) 2165 (fill-paragraph nil) 2166 (goto-char (marker-position goback))) 2167 (widen)) 2168 (forward-line 1))))))) 2169 2170(defun article-capitalize-sentences () 2171 "Capitalize the first word in each sentence." 2172 (interactive) 2173 (save-excursion 2174 (let ((inhibit-read-only t) 2175 (paragraph-start "^[\n\^L]")) 2176 (article-goto-body) 2177 (while (not (eobp)) 2178 (capitalize-word 1) 2179 (forward-sentence))))) 2180 2181(defun article-remove-cr () 2182 "Remove trailing CRs and then translate remaining CRs into LFs." 2183 (interactive) 2184 (save-excursion 2185 (let ((inhibit-read-only t)) 2186 (goto-char (point-min)) 2187 (while (re-search-forward "\r+$" nil t) 2188 (replace-match "" t t)) 2189 (goto-char (point-min)) 2190 (while (search-forward "\r" nil t) 2191 (replace-match "\n" t t))))) 2192 2193(defun article-remove-trailing-blank-lines () 2194 "Remove all trailing blank lines from the article." 2195 (interactive) 2196 (save-excursion 2197 (let ((inhibit-read-only t)) 2198 (goto-char (point-max)) 2199 (delete-region 2200 (point) 2201 (progn 2202 (while (and (not (bobp)) 2203 (looking-at "^[ \t]*$") 2204 (not (gnus-annotation-in-region-p 2205 (point) (gnus-point-at-eol)))) 2206 (forward-line -1)) 2207 (forward-line 1) 2208 (point)))))) 2209 2210(defun article-display-face () 2211 "Display any Face headers in the header." 2212 (interactive) 2213 (let ((wash-face-p buffer-read-only)) 2214 (gnus-with-article-headers 2215 ;; When displaying parts, this function can be called several times on 2216 ;; the same article, without any intended toggle semantic (as typing `W 2217 ;; D d' would have). So face deletion must occur only when we come from 2218 ;; an interactive command, that is when the *Article* buffer is 2219 ;; read-only. 2220 (if (and wash-face-p (memq 'face gnus-article-wash-types)) 2221 (gnus-delete-images 'face) 2222 (let (face faces from) 2223 (save-current-buffer 2224 (when (and wash-face-p 2225 (gnus-buffer-live-p gnus-original-article-buffer) 2226 (not (re-search-forward "^Face:[\t ]*" nil t))) 2227 (set-buffer gnus-original-article-buffer)) 2228 (save-restriction 2229 (mail-narrow-to-head) 2230 (while (gnus-article-goto-header "Face") 2231 (push (mail-header-field-value) faces)))) 2232 (when faces 2233 (goto-char (point-min)) 2234 (let ((from (gnus-article-goto-header "from")) 2235 png image) 2236 (unless from 2237 (insert "From:") 2238 (setq from (point)) 2239 (insert "[no `from' set]\n")) 2240 (while faces 2241 (when (setq png (gnus-convert-face-to-png (pop faces))) 2242 (setq image (gnus-create-image png 'png t)) 2243 (goto-char from) 2244 (gnus-add-wash-type 'face) 2245 (gnus-add-image 'face image) 2246 (gnus-put-image image nil 'face)))))))))) 2247 2248(defun article-display-x-face (&optional force) 2249 "Look for an X-Face header and display it if present." 2250 (interactive (list 'force)) 2251 (let ((wash-face-p buffer-read-only)) ;; When type `W f' 2252 (gnus-with-article-headers 2253 ;; Delete the old process, if any. 2254 (when (process-status "article-x-face") 2255 (delete-process "article-x-face")) 2256 ;; See the comment in `article-display-face'. 2257 (if (and wash-face-p (memq 'xface gnus-article-wash-types)) 2258 ;; We have already displayed X-Faces, so we remove them 2259 ;; instead. 2260 (gnus-delete-images 'xface) 2261 ;; Display X-Faces. 2262 (let (x-faces from face) 2263 (save-current-buffer 2264 (when (and wash-face-p 2265 (gnus-buffer-live-p gnus-original-article-buffer) 2266 (not (re-search-forward "^X-Face:[\t ]*" nil t))) 2267 ;; If type `W f', use gnus-original-article-buffer, 2268 ;; otherwise use the current buffer because displaying 2269 ;; RFC822 parts calls this function too. 2270 (set-buffer gnus-original-article-buffer)) 2271 (save-restriction 2272 (mail-narrow-to-head) 2273 (while (gnus-article-goto-header "X-Face") 2274 (push (mail-header-field-value) x-faces)) 2275 (setq from (message-fetch-field "from")))) 2276 ;; Sending multiple EOFs to xv doesn't work, so we only do a 2277 ;; single external face. 2278 (when (stringp gnus-article-x-face-command) 2279 (setq x-faces (list (car x-faces)))) 2280 (when (and x-faces 2281 gnus-article-x-face-command 2282 (or force 2283 ;; Check whether this face is censored. 2284 (not gnus-article-x-face-too-ugly) 2285 (and from 2286 (not (string-match gnus-article-x-face-too-ugly 2287 from))))) 2288 (while (setq face (pop x-faces)) 2289 ;; We display the face. 2290 (cond ((stringp gnus-article-x-face-command) 2291 ;; The command is a string, so we interpret the command 2292 ;; as a, well, command, and fork it off. 2293 (let ((process-connection-type nil)) 2294 (gnus-set-process-query-on-exit-flag 2295 (start-process 2296 "article-x-face" nil shell-file-name 2297 shell-command-switch gnus-article-x-face-command) 2298 nil) 2299 (with-temp-buffer 2300 (insert face) 2301 (process-send-region "article-x-face" 2302 (point-min) (point-max))) 2303 (process-send-eof "article-x-face"))) 2304 ((functionp gnus-article-x-face-command) 2305 ;; The command is a lisp function, so we call it. 2306 (funcall gnus-article-x-face-command face)) 2307 (t 2308 (error "%s is not a function" 2309 gnus-article-x-face-command)))))))))) 2310 2311(defun article-decode-mime-words () 2312 "Decode all MIME-encoded words in the article." 2313 (interactive) 2314 (save-excursion 2315 (set-buffer gnus-article-buffer) 2316 (let ((inhibit-point-motion-hooks t) 2317 (inhibit-read-only t) 2318 (mail-parse-charset gnus-newsgroup-charset) 2319 (mail-parse-ignored-charsets 2320 (save-excursion (set-buffer gnus-summary-buffer) 2321 gnus-newsgroup-ignored-charsets))) 2322 (mail-decode-encoded-word-region (point-min) (point-max))))) 2323 2324(defun article-decode-charset (&optional prompt) 2325 "Decode charset-encoded text in the article. 2326If PROMPT (the prefix), prompt for a coding system to use." 2327 (interactive "P") 2328 (let ((inhibit-point-motion-hooks t) (case-fold-search t) 2329 (inhibit-read-only t) 2330 (mail-parse-charset gnus-newsgroup-charset) 2331 (mail-parse-ignored-charsets 2332 (save-excursion (condition-case nil 2333 (set-buffer gnus-summary-buffer) 2334 (error)) 2335 gnus-newsgroup-ignored-charsets)) 2336 ct cte ctl charset format) 2337 (save-excursion 2338 (save-restriction 2339 (article-narrow-to-head) 2340 (setq ct (message-fetch-field "Content-Type" t) 2341 cte (message-fetch-field "Content-Transfer-Encoding" t) 2342 ctl (and ct (mail-header-parse-content-type ct)) 2343 charset (cond 2344 (prompt 2345 (mm-read-coding-system "Charset to decode: ")) 2346 (ctl 2347 (mail-content-type-get ctl 'charset))) 2348 format (and ctl (mail-content-type-get ctl 'format))) 2349 (when cte 2350 (setq cte (mail-header-strip cte))) 2351 (if (and ctl (not (string-match "/" (car ctl)))) 2352 (setq ctl nil)) 2353 (goto-char (point-max))) 2354 (forward-line 1) 2355 (save-restriction 2356 (narrow-to-region (point) (point-max)) 2357 (when (and (eq mail-parse-charset 'gnus-decoded) 2358 (eq (mm-body-7-or-8) '8bit)) 2359 ;; The text code could have been decoded. 2360 (setq charset mail-parse-charset)) 2361 (when (and (or (not ctl) 2362 (equal (car ctl) "text/plain")) 2363 (not format)) ;; article with format will decode later. 2364 (mm-decode-body 2365 charset (and cte (intern (downcase 2366 (gnus-strip-whitespace cte)))) 2367 (car ctl))))))) 2368 2369(defun article-decode-encoded-words () 2370 "Remove encoded-word encoding from headers." 2371 (let ((inhibit-point-motion-hooks t) 2372 (mail-parse-charset gnus-newsgroup-charset) 2373 (mail-parse-ignored-charsets 2374 (save-excursion (condition-case nil 2375 (set-buffer gnus-summary-buffer) 2376 (error)) 2377 gnus-newsgroup-ignored-charsets)) 2378 (inhibit-read-only t) 2379 end start) 2380 (goto-char (point-min)) 2381 (when (search-forward "\n\n" nil 'move) 2382 (forward-line -1)) 2383 (setq end (point)) 2384 (while (not (bobp)) 2385 (while (progn 2386 (forward-line -1) 2387 (and (not (bobp)) 2388 (memq (char-after) '(?\t ? ))))) 2389 (setq start (point)) 2390 (if (looking-at "\ 2391\\(?:Resent-\\)?\\(?:From\\|Cc\\|To\\|Bcc\\|\\(?:In-\\)?Reply-To\\|Sender\ 2392\\|Mail-Followup-To\\|Mail-Copies-To\\|Approved\\):") 2393 (funcall gnus-decode-address-function start end) 2394 (funcall gnus-decode-header-function start end)) 2395 (goto-char (setq end start))))) 2396 2397(defun article-decode-group-name () 2398 "Decode group names in `Newsgroups:'." 2399 (let ((inhibit-point-motion-hooks t) 2400 (inhibit-read-only t) 2401 (method (gnus-find-method-for-group gnus-newsgroup-name))) 2402 (when (and (or gnus-group-name-charset-method-alist 2403 gnus-group-name-charset-group-alist) 2404 (gnus-buffer-live-p gnus-original-article-buffer)) 2405 (save-restriction 2406 (article-narrow-to-head) 2407 (with-current-buffer gnus-original-article-buffer 2408 (goto-char (point-min))) 2409 (while (re-search-forward 2410 "^Newsgroups:\\(\\(.\\|\n[\t ]\\)*\\)\n[^\t ]" nil t) 2411 (replace-match (save-match-data 2412 (gnus-decode-newsgroups 2413 ;; XXX how to use data in article buffer? 2414 (with-current-buffer gnus-original-article-buffer 2415 (re-search-forward 2416 "^Newsgroups:\\(\\(.\\|\n[\t ]\\)*\\)\n[^\t ]" 2417 nil t) 2418 (match-string 1)) 2419 gnus-newsgroup-name method)) 2420 t t nil 1)) 2421 (goto-char (point-min)) 2422 (with-current-buffer gnus-original-article-buffer 2423 (goto-char (point-min))) 2424 (while (re-search-forward 2425 "^Followup-To:\\(\\(.\\|\n[\t ]\\)*\\)\n[^\t ]" nil t) 2426 (replace-match (save-match-data 2427 (gnus-decode-newsgroups 2428 ;; XXX how to use data in article buffer? 2429 (with-current-buffer gnus-original-article-buffer 2430 (re-search-forward 2431 "^Followup-To:\\(\\(.\\|\n[\t ]\\)*\\)\n[^\t ]" 2432 nil t) 2433 (match-string 1)) 2434 gnus-newsgroup-name method)) 2435 t t nil 1)))))) 2436 2437(autoload 'idna-to-unicode "idna") 2438 2439(defun article-decode-idna-rhs () 2440 "Decode IDNA strings in RHS in various headers in current buffer. 2441The following headers are decoded: From:, To:, Cc:, Reply-To:, 2442Mail-Reply-To: and Mail-Followup-To:." 2443 (when gnus-use-idna 2444 (save-restriction 2445 (let ((inhibit-point-motion-hooks t) 2446 (inhibit-read-only t)) 2447 (article-narrow-to-head) 2448 (goto-char (point-min)) 2449 (while (re-search-forward "@[^ \t\n\r,>]*\\(xn--[-A-Za-z0-9.]*\\)[ \t\n\r,>]" nil t) 2450 (let (ace unicode) 2451 (when (save-match-data 2452 (and (setq ace (match-string 1)) 2453 (save-excursion 2454 (and (re-search-backward "^[^ \t]" nil t) 2455 (looking-at "From\\|To\\|Cc\\|Reply-To\\|Mail-Reply-To\\|Mail-Followup-To"))) 2456 (setq unicode (idna-to-unicode ace)))) 2457 (unless (string= ace unicode) 2458 (replace-match unicode nil nil nil 1))))))))) 2459 2460(defun article-de-quoted-unreadable (&optional force read-charset) 2461 "Translate a quoted-printable-encoded article. 2462If FORCE, decode the article whether it is marked as quoted-printable 2463or not. 2464If READ-CHARSET, ask for a coding system." 2465 (interactive (list 'force current-prefix-arg)) 2466 (save-excursion 2467 (let ((inhibit-read-only t) type charset) 2468 (if (gnus-buffer-live-p gnus-original-article-buffer) 2469 (with-current-buffer gnus-original-article-buffer 2470 (setq type 2471 (gnus-fetch-field "content-transfer-encoding")) 2472 (let* ((ct (gnus-fetch-field "content-type")) 2473 (ctl (and ct (mail-header-parse-content-type ct)))) 2474 (setq charset (and ctl 2475 (mail-content-type-get ctl 'charset))) 2476 (if (stringp charset) 2477 (setq charset (intern (downcase charset))))))) 2478 (if read-charset 2479 (setq charset (mm-read-coding-system "Charset: " charset))) 2480 (unless charset 2481 (setq charset gnus-newsgroup-charset)) 2482 (when (or force 2483 (and type (let ((case-fold-search t)) 2484 (string-match "quoted-printable" type)))) 2485 (article-goto-body) 2486 (quoted-printable-decode-region 2487 (point) (point-max) (mm-charset-to-coding-system charset)))))) 2488 2489(defun article-de-base64-unreadable (&optional force read-charset) 2490 "Translate a base64 article. 2491If FORCE, decode the article whether it is marked as base64 not. 2492If READ-CHARSET, ask for a coding system." 2493 (interactive (list 'force current-prefix-arg)) 2494 (save-excursion 2495 (let ((inhibit-read-only t) type charset) 2496 (if (gnus-buffer-live-p gnus-original-article-buffer) 2497 (with-current-buffer gnus-original-article-buffer 2498 (setq type 2499 (gnus-fetch-field "content-transfer-encoding")) 2500 (let* ((ct (gnus-fetch-field "content-type")) 2501 (ctl (and ct (mail-header-parse-content-type ct)))) 2502 (setq charset (and ctl 2503 (mail-content-type-get ctl 'charset))) 2504 (if (stringp charset) 2505 (setq charset (intern (downcase charset))))))) 2506 (if read-charset 2507 (setq charset (mm-read-coding-system "Charset: " charset))) 2508 (unless charset 2509 (setq charset gnus-newsgroup-charset)) 2510 (when (or force 2511 (and type (let ((case-fold-search t)) 2512 (string-match "base64" type)))) 2513 (article-goto-body) 2514 (save-restriction 2515 (narrow-to-region (point) (point-max)) 2516 (base64-decode-region (point-min) (point-max)) 2517 (mm-decode-coding-region 2518 (point-min) (point-max) (mm-charset-to-coding-system charset))))))) 2519 2520(eval-when-compile 2521 (require 'rfc1843)) 2522 2523(defun article-decode-HZ () 2524 "Translate a HZ-encoded article." 2525 (interactive) 2526 (require 'rfc1843) 2527 (save-excursion 2528 (let ((inhibit-read-only t)) 2529 (rfc1843-decode-region (point-min) (point-max))))) 2530 2531(defun article-unsplit-urls () 2532 "Remove the newlines that some other mailers insert into URLs." 2533 (interactive) 2534 (save-excursion 2535 (let ((inhibit-read-only t)) 2536 (goto-char (point-min)) 2537 (while (re-search-forward 2538 "\\(\\(https?\\|ftp\\)://\\S-+\\) *\n\\(\\S-+\\)" nil t) 2539 (replace-match "\\1\\3" t))) 2540 (when (interactive-p) 2541 (gnus-treat-article nil)))) 2542 2543 2544(defun article-wash-html (&optional read-charset) 2545 "Format an HTML article. 2546If READ-CHARSET, ask for a coding system. If it is a number, the 2547charset defined in `gnus-summary-show-article-charset-alist' is used." 2548 (interactive "P") 2549 (save-excursion 2550 (let ((inhibit-read-only t) 2551 charset) 2552 (if read-charset 2553 (if (or (and (numberp read-charset) 2554 (setq charset 2555 (cdr 2556 (assq read-charset 2557 gnus-summary-show-article-charset-alist)))) 2558 (setq charset (mm-read-coding-system "Charset: "))) 2559 (let ((gnus-summary-show-article-charset-alist 2560 (list (cons 1 charset)))) 2561 (with-current-buffer gnus-summary-buffer 2562 (gnus-summary-show-article 1))) 2563 (error "No charset is given")) 2564 (when (gnus-buffer-live-p gnus-original-article-buffer) 2565 (with-current-buffer gnus-original-article-buffer 2566 (let* ((ct (gnus-fetch-field "content-type")) 2567 (ctl (and ct (mail-header-parse-content-type ct)))) 2568 (setq charset (and ctl 2569 (mail-content-type-get ctl 'charset))) 2570 (when (stringp charset) 2571 (setq charset (intern (downcase charset))))))) 2572 (unless charset 2573 (setq charset gnus-newsgroup-charset))) 2574 (article-goto-body) 2575 (save-window-excursion 2576 (save-restriction 2577 (narrow-to-region (point) (point-max)) 2578 (let* ((func (or gnus-article-wash-function mm-text-html-renderer)) 2579 (entry (assq func mm-text-html-washer-alist))) 2580 (when entry 2581 (setq func (cdr entry))) 2582 (cond 2583 ((functionp func) 2584 (funcall func)) 2585 (t 2586 (apply (car func) (cdr func)))))))))) 2587 2588(defun gnus-article-wash-html-with-w3 () 2589 "Wash the current buffer with w3." 2590 (mm-setup-w3) 2591 (let ((w3-strict-width (window-width)) 2592 (url-standalone-mode t) 2593 (url-gateway-unplugged t) 2594 (w3-honor-stylesheets nil)) 2595 (condition-case () 2596 (w3-region (point-min) (point-max)) 2597 (error)))) 2598 2599(defun gnus-article-wash-html-with-w3m () 2600 "Wash the current buffer with emacs-w3m." 2601 (mm-setup-w3m) 2602 (let ((w3m-safe-url-regexp mm-w3m-safe-url-regexp) 2603 w3m-force-redisplay) 2604 (w3m-region (point-min) (point-max))) 2605 (when (and mm-inline-text-html-with-w3m-keymap 2606 (boundp 'w3m-minor-mode-map) 2607 w3m-minor-mode-map) 2608 (add-text-properties 2609 (point-min) (point-max) 2610 (list 'keymap w3m-minor-mode-map 2611 ;; Put the mark meaning this part was rendered by emacs-w3m. 2612 'mm-inline-text-html-with-w3m t)))) 2613 2614(eval-when-compile (defvar charset)) ;; Bound by `article-wash-html'. 2615 2616(defun gnus-article-wash-html-with-w3m-standalone () 2617 "Wash the current buffer with w3m." 2618 (if (mm-w3m-standalone-supports-m17n-p) 2619 (progn 2620 (unless (mm-coding-system-p charset) ;; Bound by `article-wash-html'. 2621 ;; The default. 2622 (setq charset 'iso-8859-1)) 2623 (let ((coding-system-for-write charset) 2624 (coding-system-for-read charset)) 2625 (call-process-region 2626 (point-min) (point-max) 2627 "w3m" t t nil "-dump" "-T" "text/html" 2628 "-I" (symbol-name charset) "-O" (symbol-name charset)))) 2629 (mm-inline-wash-with-stdin nil "w3m" "-dump" "-T" "text/html"))) 2630 2631(defun article-hide-list-identifiers () 2632 "Remove list identifies from the Subject header. 2633The `gnus-list-identifiers' variable specifies what to do." 2634 (interactive) 2635 (let ((inhibit-point-motion-hooks t) 2636 (regexp (if (consp gnus-list-identifiers) 2637 (mapconcat 'identity gnus-list-identifiers " *\\|") 2638 gnus-list-identifiers)) 2639 (inhibit-read-only t)) 2640 (when regexp 2641 (save-excursion 2642 (save-restriction 2643 (article-narrow-to-head) 2644 (goto-char (point-min)) 2645 (while (re-search-forward 2646 (concat "^Subject: +\\(R[Ee]: +\\)*\\(" regexp " *\\)") 2647 nil t) 2648 (delete-region (match-beginning 2) (match-end 0)) 2649 (beginning-of-line)) 2650 (when (re-search-forward 2651 "^Subject: +\\(\\(R[Ee]: +\\)+\\)R[Ee]: +" nil t) 2652 (delete-region (match-beginning 1) (match-end 1)))))))) 2653 2654(defun article-hide-pem (&optional arg) 2655 "Toggle hiding of any PEM headers and signatures in the current article. 2656If given a negative prefix, always show; if given a positive prefix, 2657always hide." 2658 (interactive (gnus-article-hidden-arg)) 2659 (unless (gnus-article-check-hidden-text 'pem arg) 2660 (save-excursion 2661 (let ((inhibit-read-only t) end) 2662 (goto-char (point-min)) 2663 ;; Hide the horrendously ugly "header". 2664 (when (and (search-forward 2665 "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n" 2666 nil t) 2667 (setq end (1+ (match-beginning 0)))) 2668 (gnus-add-wash-type 'pem) 2669 (gnus-article-hide-text-type 2670 end 2671 (if (search-forward "\n\n" nil t) 2672 (match-end 0) 2673 (point-max)) 2674 'pem) 2675 ;; Hide the trailer as well 2676 (when (search-forward "\n-----END PRIVACY-ENHANCED MESSAGE-----\n" 2677 nil t) 2678 (gnus-article-hide-text-type 2679 (match-beginning 0) (match-end 0) 'pem))))))) 2680 2681(defun article-strip-banner () 2682 "Strip the banners specified by the `banner' group parameter and by 2683`gnus-article-address-banner-alist'." 2684 (interactive) 2685 (save-excursion 2686 (save-restriction 2687 (let ((inhibit-point-motion-hooks t)) 2688 (when (gnus-parameter-banner gnus-newsgroup-name) 2689 (article-really-strip-banner 2690 (gnus-parameter-banner gnus-newsgroup-name))) 2691 (when gnus-article-address-banner-alist 2692 ;; Note that the From header is decoded here, so it is 2693 ;; required that the *-extract-address-components function 2694 ;; supports non-ASCII text. 2695 (let ((from (save-restriction 2696 (widen) 2697 (article-narrow-to-head) 2698 (mail-fetch-field "from")))) 2699 (when (and from 2700 (setq from 2701 (cadr (funcall gnus-extract-address-components 2702 from)))) 2703 (catch 'found 2704 (dolist (pair gnus-article-address-banner-alist) 2705 (when (string-match (car pair) from) 2706 (throw 'found 2707 (article-really-strip-banner (cdr pair))))))))))))) 2708 2709(defun article-really-strip-banner (banner) 2710 "Strip the banner specified by the argument." 2711 (save-excursion 2712 (save-restriction 2713 (let ((inhibit-point-motion-hooks t) 2714 (gnus-signature-limit nil) 2715 (inhibit-read-only t)) 2716 (article-goto-body) 2717 (cond 2718 ((eq banner 'signature) 2719 (when (gnus-article-narrow-to-signature) 2720 (widen) 2721 (forward-line -1) 2722 (delete-region (point) (point-max)))) 2723 ((symbolp banner) 2724 (if (setq banner (cdr (assq banner gnus-article-banner-alist))) 2725 (while (re-search-forward banner nil t) 2726 (delete-region (match-beginning 0) (match-end 0))))) 2727 ((stringp banner) 2728 (while (re-search-forward banner nil t) 2729 (delete-region (match-beginning 0) (match-end 0))))))))) 2730 2731(defun article-babel () 2732 "Translate article using an online translation service." 2733 (interactive) 2734 (require 'babel) 2735 (save-excursion 2736 (set-buffer gnus-article-buffer) 2737 (when (article-goto-body) 2738 (let* ((inhibit-read-only t) 2739 (start (point)) 2740 (end (point-max)) 2741 (orig (buffer-substring start end)) 2742 (trans (babel-as-string orig))) 2743 (save-restriction 2744 (narrow-to-region start end) 2745 (delete-region start end) 2746 (insert trans)))))) 2747 2748(defun article-hide-signature (&optional arg) 2749 "Hide the signature in the current article. 2750If given a negative prefix, always show; if given a positive prefix, 2751always hide." 2752 (interactive (gnus-article-hidden-arg)) 2753 (unless (gnus-article-check-hidden-text 'signature arg) 2754 (save-excursion 2755 (save-restriction 2756 (let ((inhibit-read-only t)) 2757 (when (gnus-article-narrow-to-signature) 2758 (gnus-article-hide-text-type 2759 (point-min) (point-max) 'signature)))))) 2760 (gnus-set-mode-line 'article)) 2761 2762(defun article-strip-headers-in-body () 2763 "Strip offensive headers from bodies." 2764 (interactive) 2765 (save-excursion 2766 (article-goto-body) 2767 (let ((case-fold-search t)) 2768 (when (looking-at "x-no-archive:") 2769 (gnus-delete-line))))) 2770 2771(defun article-strip-leading-blank-lines () 2772 "Remove all blank lines from the beginning of the article." 2773 (interactive) 2774 (save-excursion 2775 (let ((inhibit-point-motion-hooks t) 2776 (inhibit-read-only t)) 2777 (when (article-goto-body) 2778 (while (and (not (eobp)) 2779 (looking-at "[ \t]*$")) 2780 (gnus-delete-line)))))) 2781 2782(defun article-narrow-to-head () 2783 "Narrow the buffer to the head of the message. 2784Point is left at the beginning of the narrowed-to region." 2785 (narrow-to-region 2786 (goto-char (point-min)) 2787 (if (search-forward "\n\n" nil 1) 2788 (1- (point)) 2789 (point-max))) 2790 (goto-char (point-min))) 2791 2792(defun article-goto-body () 2793 "Place point at the start of the body." 2794 (goto-char (point-min)) 2795 (cond 2796 ;; This variable is only bound when dealing with separate 2797 ;; MIME body parts. 2798 (article-goto-body-goes-to-point-min-p 2799 t) 2800 ((search-forward "\n\n" nil t) 2801 t) 2802 (t 2803 (goto-char (point-max)) 2804 nil))) 2805 2806(defun article-strip-multiple-blank-lines () 2807 "Replace consecutive blank lines with one empty line." 2808 (interactive) 2809 (save-excursion 2810 (let ((inhibit-point-motion-hooks t) 2811 (inhibit-read-only t)) 2812 ;; First make all blank lines empty. 2813 (article-goto-body) 2814 (while (re-search-forward "^[ \t]+$" nil t) 2815 (unless (gnus-annotation-in-region-p 2816 (match-beginning 0) (match-end 0)) 2817 (replace-match "" nil t))) 2818 ;; Then replace multiple empty lines with a single empty line. 2819 (article-goto-body) 2820 (while (re-search-forward "\n\n\\(\n+\\)" nil t) 2821 (unless (gnus-annotation-in-region-p 2822 (match-beginning 0) (match-end 0)) 2823 (delete-region (match-beginning 1) (match-end 1))))))) 2824 2825(defun article-strip-leading-space () 2826 "Remove all white space from the beginning of the lines in the article." 2827 (interactive) 2828 (save-excursion 2829 (let ((inhibit-point-motion-hooks t) 2830 (inhibit-read-only t)) 2831 (article-goto-body) 2832 (while (re-search-forward "^[ \t]+" nil t) 2833 (replace-match "" t t))))) 2834 2835(defun article-strip-trailing-space () 2836 "Remove all white space from the end of the lines in the article." 2837 (interactive) 2838 (save-excursion 2839 (let ((inhibit-point-motion-hooks t) 2840 (inhibit-read-only t)) 2841 (article-goto-body) 2842 (while (re-search-forward "[ \t]+$" nil t) 2843 (replace-match "" t t))))) 2844 2845(defun article-strip-blank-lines () 2846 "Strip leading, trailing and multiple blank lines." 2847 (interactive) 2848 (article-strip-leading-blank-lines) 2849 (article-remove-trailing-blank-lines) 2850 (article-strip-multiple-blank-lines)) 2851 2852(defun article-strip-all-blank-lines () 2853 "Strip all blank lines." 2854 (interactive) 2855 (save-excursion 2856 (let ((inhibit-point-motion-hooks t) 2857 (inhibit-read-only t)) 2858 (article-goto-body) 2859 (while (re-search-forward "^[ \t]*\n" nil t) 2860 (replace-match "" t t))))) 2861 2862(defun gnus-article-narrow-to-signature () 2863 "Narrow to the signature; return t if a signature is found, else nil." 2864 (let ((inhibit-point-motion-hooks t)) 2865 (when (gnus-article-search-signature) 2866 (forward-line 1) 2867 ;; Check whether we have some limits to what we consider 2868 ;; to be a signature. 2869 (let ((limits (if (listp gnus-signature-limit) gnus-signature-limit 2870 (list gnus-signature-limit))) 2871 limit limited) 2872 (while (setq limit (pop limits)) 2873 (if (or (and (integerp limit) 2874 (< (- (point-max) (point)) limit)) 2875 (and (floatp limit) 2876 (< (count-lines (point) (point-max)) limit)) 2877 (and (functionp limit) 2878 (funcall limit)) 2879 (and (stringp limit) 2880 (not (re-search-forward limit nil t)))) 2881 () ; This limit did not succeed. 2882 (setq limited t 2883 limits nil))) 2884 (unless limited 2885 (narrow-to-region (point) (point-max)) 2886 t))))) 2887 2888(defun gnus-article-search-signature () 2889 "Search the current buffer for the signature separator. 2890Put point at the beginning of the signature separator." 2891 (let ((cur (point))) 2892 (goto-char (point-max)) 2893 (if (if (stringp gnus-signature-separator) 2894 (re-search-backward gnus-signature-separator nil t) 2895 (let ((seps gnus-signature-separator)) 2896 (while (and seps 2897 (not (re-search-backward (car seps) nil t))) 2898 (pop seps)) 2899 seps)) 2900 t 2901 (goto-char cur) 2902 nil))) 2903 2904(defun gnus-article-hidden-arg () 2905 "Return the current prefix arg as a number, or 0 if no prefix." 2906 (list (if current-prefix-arg 2907 (prefix-numeric-value current-prefix-arg) 2908 0))) 2909 2910(defun gnus-article-check-hidden-text (type arg) 2911 "Return nil if hiding is necessary. 2912Arg can be nil or a number. nil and positive means hide, negative 2913means show, 0 means toggle." 2914 (save-excursion 2915 (save-restriction 2916 (let ((hide (gnus-article-hidden-text-p type))) 2917 (cond 2918 ((or (null arg) 2919 (> arg 0)) 2920 nil) 2921 ((< arg 0) 2922 (gnus-article-show-hidden-text type) 2923 t) 2924 (t 2925 (if (eq hide 'hidden) 2926 (progn 2927 (gnus-article-show-hidden-text type) 2928 t) 2929 nil))))))) 2930 2931(defun gnus-article-hidden-text-p (type) 2932 "Say whether the current buffer contains hidden text of type TYPE." 2933 (let ((pos (text-property-any (point-min) (point-max) 'article-type type))) 2934 (while (and pos 2935 (not (get-text-property pos 'invisible)) 2936 (not (get-text-property pos 'dummy-invisible))) 2937 (setq pos 2938 (text-property-any (1+ pos) (point-max) 'article-type type))) 2939 (if pos 2940 'hidden 2941 nil))) 2942 2943(defun gnus-article-show-hidden-text (type &optional dummy) 2944 "Show all hidden text of type TYPE. 2945Originally it is hide instead of DUMMY." 2946 (let ((inhibit-read-only t) 2947 (inhibit-point-motion-hooks t)) 2948 (gnus-remove-text-properties-when 2949 'article-type type 2950 (point-min) (point-max) 2951 (cons 'article-type (cons type 2952 gnus-hidden-properties))) 2953 (gnus-delete-wash-type type))) 2954 2955(defconst article-time-units 2956 `((year . ,(* 365.25 24 60 60)) 2957 (week . ,(* 7 24 60 60)) 2958 (day . ,(* 24 60 60)) 2959 (hour . ,(* 60 60)) 2960 (minute . 60) 2961 (second . 1)) 2962 "Mapping from time units to seconds.") 2963 2964(defun gnus-article-forward-header () 2965 "Move point to the start of the next header. 2966If the current header is a continuation header, this can be several 2967lines forward." 2968 (let ((ended nil)) 2969 (while (not ended) 2970 (forward-line 1) 2971 (if (looking-at "[ \t]+[^ \t]") 2972 (forward-line 1) 2973 (setq ended t))))) 2974 2975(defun article-date-ut (&optional type highlight) 2976 "Convert DATE date to universal time in the current article. 2977If TYPE is `local', convert to local time; if it is `lapsed', output 2978how much time has lapsed since DATE. For `lapsed', the value of 2979`gnus-article-date-lapsed-new-header' says whether the \"X-Sent:\" header 2980should replace the \"Date:\" one, or should be added below it." 2981 (interactive (list 'ut t)) 2982 (let* ((tdate-regexp "^Date:[ \t]\\|^X-Sent:[ \t]") 2983 (date-regexp (cond ((not gnus-article-date-lapsed-new-header) 2984 tdate-regexp) 2985 ((eq type 'lapsed) 2986 "^X-Sent:[ \t]") 2987 (article-lapsed-timer 2988 "^Date:[ \t]") 2989 (t 2990 tdate-regexp))) 2991 (case-fold-search t) 2992 (inhibit-read-only t) 2993 (inhibit-point-motion-hooks t) 2994 pos date bface eface) 2995 (save-excursion 2996 (save-restriction 2997 (widen) 2998 (goto-char (point-min)) 2999 (while (or (setq date (get-text-property (setq pos (point)) 3000 'original-date)) 3001 (when (setq pos (next-single-property-change 3002 (point) 'original-date)) 3003 (setq date (get-text-property pos 'original-date)) 3004 t)) 3005 (narrow-to-region pos (or (text-property-any pos (point-max) 3006 'original-date nil) 3007 (point-max))) 3008 (goto-char (point-min)) 3009 (when (re-search-forward tdate-regexp nil t) 3010 (setq bface (get-text-property (gnus-point-at-bol) 'face) 3011 eface (get-text-property (1- (gnus-point-at-eol)) 'face))) 3012 (goto-char (point-min)) 3013 (setq pos nil) 3014 ;; Delete any old Date headers. 3015 (while (re-search-forward date-regexp nil t) 3016 (if pos 3017 (delete-region (gnus-point-at-bol) 3018 (progn 3019 (gnus-article-forward-header) 3020 (point))) 3021 (delete-region (gnus-point-at-bol) 3022 (progn 3023 (gnus-article-forward-header) 3024 (forward-char -1) 3025 (point))) 3026 (setq pos (point)))) 3027 (when (and (not pos) 3028 (re-search-forward tdate-regexp nil t)) 3029 (forward-line 1)) 3030 (gnus-goto-char pos) 3031 (insert (article-make-date-line date (or type 'ut))) 3032 (unless pos 3033 (insert "\n") 3034 (forward-line -1)) 3035 ;; Do highlighting. 3036 (beginning-of-line) 3037 (when (looking-at "\\([^:]+\\): *\\(.*\\)$") 3038 (put-text-property (match-beginning 1) (1+ (match-end 1)) 3039 'face bface) 3040 (put-text-property (match-beginning 2) (match-end 2) 3041 'face eface)) 3042 (put-text-property (point-min) (1- (point-max)) 'original-date date) 3043 (goto-char (point-max)) 3044 (widen)))))) 3045 3046(defun article-make-date-line (date type) 3047 "Return a DATE line of TYPE." 3048 (unless (memq type '(local ut original user iso8601 lapsed english)) 3049 (error "Unknown conversion type: %s" type)) 3050 (condition-case () 3051 (let ((time (date-to-time date))) 3052 (cond 3053 ;; Convert to the local timezone. 3054 ((eq type 'local) 3055 (let ((tz (car (current-time-zone time)))) 3056 (format "Date: %s %s%02d%02d" (current-time-string time) 3057 (if (> tz 0) "+" "-") (/ (abs tz) 3600) 3058 (/ (% (abs tz) 3600) 60)))) 3059 ;; Convert to Universal Time. 3060 ((eq type 'ut) 3061 (concat "Date: " 3062 (current-time-string 3063 (let* ((e (parse-time-string date)) 3064 (tm (apply 'encode-time e)) 3065 (ms (car tm)) 3066 (ls (- (cadr tm) (car (current-time-zone time))))) 3067 (cond ((< ls 0) (list (1- ms) (+ ls 65536))) 3068 ((> ls 65535) (list (1+ ms) (- ls 65536))) 3069 (t (list ms ls))))) 3070 " UT")) 3071 ;; Get the original date from the article. 3072 ((eq type 'original) 3073 (concat "Date: " (if (string-match "\n+$" date) 3074 (substring date 0 (match-beginning 0)) 3075 date))) 3076 ;; Let the user define the format. 3077 ((eq type 'user) 3078 (let ((format (or (condition-case nil 3079 (with-current-buffer gnus-summary-buffer 3080 gnus-article-time-format) 3081 (error nil)) 3082 gnus-article-time-format))) 3083 (if (functionp format) 3084 (funcall format time) 3085 (concat "Date: " (format-time-string format time))))) 3086 ;; ISO 8601. 3087 ((eq type 'iso8601) 3088 (let ((tz (car (current-time-zone time)))) 3089 (concat 3090 "Date: " 3091 (format-time-string "%Y%m%dT%H%M%S" time) 3092 (format "%s%02d%02d" 3093 (if (> tz 0) "+" "-") (/ (abs tz) 3600) 3094 (/ (% (abs tz) 3600) 60))))) 3095 ;; Do an X-Sent lapsed format. 3096 ((eq type 'lapsed) 3097 ;; If the date is seriously mangled, the timezone functions are 3098 ;; liable to bug out, so we ignore all errors. 3099 (let* ((now (current-time)) 3100 (real-time (subtract-time now time)) 3101 (real-sec (and real-time 3102 (+ (* (float (car real-time)) 65536) 3103 (cadr real-time)))) 3104 (sec (and real-time (abs real-sec))) 3105 num prev) 3106 (cond 3107 ((null real-time) 3108 "X-Sent: Unknown") 3109 ((zerop sec) 3110 "X-Sent: Now") 3111 (t 3112 (concat 3113 "X-Sent: " 3114 ;; This is a bit convoluted, but basically we go 3115 ;; through the time units for years, weeks, etc, 3116 ;; and divide things to see whether that results 3117 ;; in positive answers. 3118 (mapconcat 3119 (lambda (unit) 3120 (if (zerop (setq num (ffloor (/ sec (cdr unit))))) 3121 ;; The (remaining) seconds are too few to 3122 ;; be divided into this time unit. 3123 "" 3124 ;; It's big enough, so we output it. 3125 (setq sec (- sec (* num (cdr unit)))) 3126 (prog1 3127 (concat (if prev ", " "") (int-to-string 3128 (floor num)) 3129 " " (symbol-name (car unit)) 3130 (if (> num 1) "s" "")) 3131 (setq prev t)))) 3132 article-time-units "") 3133 ;; If dates are odd, then it might appear like the 3134 ;; article was sent in the future. 3135 (if (> real-sec 0) 3136 " ago" 3137 " in the future")))))) 3138 ;; Display the date in proper English 3139 ((eq type 'english) 3140 (let ((dtime (decode-time time))) 3141 (concat 3142 "Date: the " 3143 (number-to-string (nth 3 dtime)) 3144 (let ((digit (% (nth 3 dtime) 10))) 3145 (cond 3146 ((memq (nth 3 dtime) '(11 12 13)) "th") 3147 ((= digit 1) "st") 3148 ((= digit 2) "nd") 3149 ((= digit 3) "rd") 3150 (t "th"))) 3151 " of " 3152 (nth (1- (nth 4 dtime)) gnus-english-month-names) 3153 " " 3154 (number-to-string (nth 5 dtime)) 3155 " at " 3156 (format "%02d" (nth 2 dtime)) 3157 ":" 3158 (format "%02d" (nth 1 dtime))))))) 3159 (error 3160 (format "Date: %s (from Gnus)" date)))) 3161 3162(defun article-date-local (&optional highlight) 3163 "Convert the current article date to the local timezone." 3164 (interactive (list t)) 3165 (article-date-ut 'local highlight)) 3166 3167(defun article-date-english (&optional highlight) 3168 "Convert the current article date to something that is proper English." 3169 (interactive (list t)) 3170 (article-date-ut 'english highlight)) 3171 3172(defun article-date-original (&optional highlight) 3173 "Convert the current article date to what it was originally. 3174This is only useful if you have used some other date conversion 3175function and want to see what the date was before converting." 3176 (interactive (list t)) 3177 (article-date-ut 'original highlight)) 3178 3179(defun article-date-lapsed (&optional highlight) 3180 "Convert the current article date to time lapsed since it was sent." 3181 (interactive (list t)) 3182 (article-date-ut 'lapsed highlight)) 3183 3184(defun article-update-date-lapsed () 3185 "Function to be run from a timer to update the lapsed time line." 3186 (save-match-data 3187 (let (deactivate-mark) 3188 (save-excursion 3189 (ignore-errors 3190 (walk-windows 3191 (lambda (w) 3192 (set-buffer (window-buffer w)) 3193 (when (eq major-mode 'gnus-article-mode) 3194 (let ((mark (point-marker))) 3195 (goto-char (point-min)) 3196 (when (re-search-forward "^X-Sent:" nil t) 3197 (article-date-lapsed t)) 3198 (goto-char (marker-position mark)) 3199 (move-marker mark nil)))) 3200 nil 'visible)))))) 3201 3202(defun gnus-start-date-timer (&optional n) 3203 "Start a timer to update the X-Sent header in the article buffers. 3204The numerical prefix says how frequently (in seconds) the function 3205is to run." 3206 (interactive "p") 3207 (unless n 3208 (setq n 1)) 3209 (gnus-stop-date-timer) 3210 (setq article-lapsed-timer 3211 (nnheader-run-at-time 1 n 'article-update-date-lapsed))) 3212 3213(defun gnus-stop-date-timer () 3214 "Stop the X-Sent timer." 3215 (interactive) 3216 (when article-lapsed-timer 3217 (nnheader-cancel-timer article-lapsed-timer) 3218 (setq article-lapsed-timer nil))) 3219 3220(defun article-date-user (&optional highlight) 3221 "Convert the current article date to the user-defined format. 3222This format is defined by the `gnus-article-time-format' variable." 3223 (interactive (list t)) 3224 (article-date-ut 'user highlight)) 3225 3226(defun article-date-iso8601 (&optional highlight) 3227 "Convert the current article date to ISO8601." 3228 (interactive (list t)) 3229 (article-date-ut 'iso8601 highlight)) 3230 3231(defmacro gnus-article-save-original-date (&rest forms) 3232 "Save the original date as a text property and evaluate FORMS." 3233 `(let* ((case-fold-search t) 3234 (start (progn 3235 (goto-char (point-min)) 3236 (when (and (re-search-forward "^date:[\t\n ]+" nil t) 3237 (not (bolp))) 3238 (match-end 0)))) 3239 (date (when (and start 3240 (re-search-forward "[\t ]*\n\\([^\t ]\\|\\'\\)" 3241 nil t)) 3242 (buffer-substring-no-properties start 3243 (match-beginning 0))))) 3244 (goto-char (point-max)) 3245 (skip-chars-backward "\n") 3246 (put-text-property (point-min) (point) 'original-date date) 3247 ,@forms 3248 (goto-char (point-max)) 3249 (skip-chars-backward "\n") 3250 (put-text-property (point-min) (point) 'original-date date))) 3251 3252;; (defun article-show-all () 3253;; "Show all hidden text in the article buffer." 3254;; (interactive) 3255;; (save-excursion 3256;; (let ((inhibit-read-only t)) 3257;; (gnus-article-unhide-text (point-min) (point-max))))) 3258 3259(defun article-remove-leading-whitespace () 3260 "Remove excessive whitespace from all headers." 3261 (interactive) 3262 (save-excursion 3263 (save-restriction 3264 (let ((inhibit-read-only t)) 3265 (article-narrow-to-head) 3266 (goto-char (point-min)) 3267 (while (re-search-forward "^[^ :]+: \\([ \t]+\\)" nil t) 3268 (delete-region (match-beginning 1) (match-end 1))))))) 3269 3270(defun article-emphasize (&optional arg) 3271 "Emphasize text according to `gnus-emphasis-alist'." 3272 (interactive (gnus-article-hidden-arg)) 3273 (unless (gnus-article-check-hidden-text 'emphasis arg) 3274 (save-excursion 3275 (let ((alist (or 3276 (condition-case nil 3277 (with-current-buffer gnus-summary-buffer 3278 gnus-article-emphasis-alist) 3279 (error)) 3280 gnus-emphasis-alist)) 3281 (inhibit-read-only t) 3282 (props (append '(article-type emphasis) 3283 gnus-hidden-properties)) 3284 regexp elem beg invisible visible face) 3285 (article-goto-body) 3286 (setq beg (point)) 3287 (while (setq elem (pop alist)) 3288 (goto-char beg) 3289 (setq regexp (car elem) 3290 invisible (nth 1 elem) 3291 visible (nth 2 elem) 3292 face (nth 3 elem)) 3293 (while (re-search-forward regexp nil t) 3294 (when (and (match-beginning visible) (match-beginning invisible)) 3295 (gnus-article-hide-text 3296 (match-beginning invisible) (match-end invisible) props) 3297 (gnus-article-unhide-text-type 3298 (match-beginning visible) (match-end visible) 'emphasis) 3299 (gnus-put-overlay-excluding-newlines 3300 (match-beginning visible) (match-end visible) 'face face) 3301 (gnus-add-wash-type 'emphasis) 3302 (goto-char (match-end invisible))))))))) 3303 3304(defun gnus-article-setup-highlight-words (&optional highlight-words) 3305 "Setup newsgroup emphasis alist." 3306 (unless gnus-article-emphasis-alist 3307 (let ((name (and gnus-newsgroup-name 3308 (gnus-group-real-name gnus-newsgroup-name)))) 3309 (make-local-variable 'gnus-article-emphasis-alist) 3310 (setq gnus-article-emphasis-alist 3311 (nconc 3312 (let ((alist gnus-group-highlight-words-alist) elem highlight) 3313 (while (setq elem (pop alist)) 3314 (when (and name (string-match (car elem) name)) 3315 (setq alist nil 3316 highlight (copy-sequence (cdr elem))))) 3317 highlight) 3318 (copy-sequence highlight-words) 3319 (if gnus-newsgroup-name 3320 (copy-sequence (gnus-group-find-parameter 3321 gnus-newsgroup-name 'highlight-words t))) 3322 gnus-emphasis-alist))))) 3323 3324(eval-when-compile 3325 (defvar gnus-summary-article-menu) 3326 (defvar gnus-summary-post-menu)) 3327 3328;;; Saving functions. 3329 3330(defun gnus-article-save (save-buffer file &optional num) 3331 "Save the currently selected article." 3332 (when (or (get gnus-default-article-saver :headers) 3333 (not gnus-save-all-headers)) 3334 ;; Remove headers according to `gnus-saved-headers' or the value 3335 ;; of the `:headers' property that the saver function might have. 3336 (let ((gnus-visible-headers 3337 (or (symbol-value (get gnus-default-article-saver :headers)) 3338 gnus-saved-headers gnus-visible-headers)) 3339 (gnus-article-buffer save-buffer)) 3340 (save-excursion 3341 (set-buffer save-buffer) 3342 (article-hide-headers 1 t)))) 3343 (save-window-excursion 3344 (if (not gnus-default-article-saver) 3345 (error "No default saver is defined") 3346 ;; !!! Magic! The saving functions all save 3347 ;; `gnus-save-article-buffer' (or so they think), but we 3348 ;; bind that variable to our save-buffer. 3349 (set-buffer gnus-article-buffer) 3350 (let* ((gnus-save-article-buffer save-buffer) 3351 (filename 3352 (cond 3353 ((not gnus-prompt-before-saving) 'default) 3354 ((eq gnus-prompt-before-saving 'always) nil) 3355 (t file))) 3356 (gnus-number-of-articles-to-be-saved 3357 (when (eq gnus-prompt-before-saving t) 3358 num))) ; Magic 3359 (set-buffer gnus-article-current-summary) 3360 (funcall gnus-default-article-saver filename))))) 3361 3362(defun gnus-read-save-file-name (prompt &optional filename 3363 function group headers variable 3364 dir-var) 3365 (let ((default-name 3366 (funcall function group headers (symbol-value variable))) 3367 result) 3368 (setq result 3369 (expand-file-name 3370 (cond 3371 ((eq filename 'default) 3372 default-name) 3373 ((eq filename t) 3374 default-name) 3375 (filename filename) 3376 (t 3377 (when (symbol-value dir-var) 3378 (setq default-name (expand-file-name 3379 (file-name-nondirectory default-name) 3380 (symbol-value dir-var)))) 3381 (let* ((split-name (gnus-get-split-value gnus-split-methods)) 3382 (prompt 3383 (format prompt 3384 (if (and gnus-number-of-articles-to-be-saved 3385 (> gnus-number-of-articles-to-be-saved 1)) 3386 (format "these %d articles" 3387 gnus-number-of-articles-to-be-saved) 3388 "this article"))) 3389 (file 3390 ;; Let the split methods have their say. 3391 (cond 3392 ;; No split name was found. 3393 ((null split-name) 3394 (read-file-name 3395 (concat prompt " (default " 3396 (file-name-nondirectory default-name) "): ") 3397 (file-name-directory default-name) 3398 default-name)) 3399 ;; A single group name is returned. 3400 ((stringp split-name) 3401 (setq default-name 3402 (funcall function split-name headers 3403 (symbol-value variable))) 3404 (read-file-name 3405 (concat prompt " (default " 3406 (file-name-nondirectory default-name) "): ") 3407 (file-name-directory default-name) 3408 default-name)) 3409 ;; A single split name was found 3410 ((= 1 (length split-name)) 3411 (let* ((name (expand-file-name 3412 (car split-name) 3413 gnus-article-save-directory)) 3414 (dir (cond ((file-directory-p name) 3415 (file-name-as-directory name)) 3416 ((file-exists-p name) name) 3417 (t gnus-article-save-directory)))) 3418 (read-file-name 3419 (concat prompt " (default " name "): ") 3420 dir name))) 3421 ;; A list of splits was found. 3422 (t 3423 (setq split-name (nreverse split-name)) 3424 (let (result) 3425 (let ((file-name-history 3426 (nconc split-name file-name-history))) 3427 (setq result 3428 (expand-file-name 3429 (read-file-name 3430 (concat prompt " (`M-p' for defaults): ") 3431 gnus-article-save-directory 3432 (car split-name)) 3433 gnus-article-save-directory))) 3434 (car (push result file-name-history))))))) 3435 ;; Create the directory. 3436 (gnus-make-directory (file-name-directory file)) 3437 ;; If we have read a directory, we append the default file name. 3438 (when (file-directory-p file) 3439 (setq file (expand-file-name (file-name-nondirectory 3440 default-name) 3441 (file-name-as-directory file)))) 3442 ;; Possibly translate some characters. 3443 (nnheader-translate-file-chars file)))))) 3444 (gnus-make-directory (file-name-directory result)) 3445 (when variable 3446 (set variable result)) 3447 (when dir-var 3448 (set dir-var (file-name-directory result))) 3449 result)) 3450 3451(defun gnus-article-archive-name (group) 3452 "Return the first instance of an \"Archive-name\" in the current buffer." 3453 (let ((case-fold-search t)) 3454 (when (re-search-forward "archive-name: *\\([^ \n\t]+\\)[ \t]*$" nil t) 3455 (nnheader-concat gnus-article-save-directory 3456 (match-string 1))))) 3457 3458(defun gnus-article-nndoc-name (group) 3459 "If GROUP is an nndoc group, return the name of the parent group." 3460 (when (eq (car (gnus-find-method-for-group group)) 'nndoc) 3461 (gnus-group-get-parameter group 'save-article-group))) 3462 3463(defun gnus-summary-save-in-rmail (&optional filename) 3464 "Append this article to Rmail file. 3465Optional argument FILENAME specifies file name. 3466Directory to save to is default to `gnus-article-save-directory'." 3467 (setq filename (gnus-read-save-file-name 3468 "Save %s in rmail file" filename 3469 gnus-rmail-save-name gnus-newsgroup-name 3470 gnus-current-headers 'gnus-newsgroup-last-rmail)) 3471 (gnus-eval-in-buffer-window gnus-save-article-buffer 3472 (save-excursion 3473 (save-restriction 3474 (widen) 3475 (gnus-output-to-rmail filename)))) 3476 filename) 3477 3478(defun gnus-summary-save-in-mail (&optional filename) 3479 "Append this article to Unix mail file. 3480Optional argument FILENAME specifies file name. 3481Directory to save to is default to `gnus-article-save-directory'." 3482 (setq filename (gnus-read-save-file-name 3483 "Save %s in Unix mail file" filename 3484 gnus-mail-save-name gnus-newsgroup-name 3485 gnus-current-headers 'gnus-newsgroup-last-mail)) 3486 (gnus-eval-in-buffer-window gnus-save-article-buffer 3487 (save-excursion 3488 (save-restriction 3489 (widen) 3490 (if (and (file-readable-p filename) 3491 (file-regular-p filename) 3492 (mail-file-babyl-p filename)) 3493 (rmail-output-to-rmail-file filename t) 3494 (gnus-output-to-mail filename))))) 3495 filename) 3496 3497(put 'gnus-summary-save-in-file :decode t) 3498(put 'gnus-summary-save-in-file :headers 'gnus-saved-headers) 3499(defun gnus-summary-save-in-file (&optional filename overwrite) 3500 "Append this article to file. 3501Optional argument FILENAME specifies file name. 3502Directory to save to is default to `gnus-article-save-directory'." 3503 (setq filename (gnus-read-save-file-name 3504 "Save %s in file" filename 3505 gnus-file-save-name gnus-newsgroup-name 3506 gnus-current-headers 'gnus-newsgroup-last-file)) 3507 (gnus-eval-in-buffer-window gnus-save-article-buffer 3508 (save-excursion 3509 (save-restriction 3510 (widen) 3511 (when (and overwrite 3512 (file-exists-p filename)) 3513 (delete-file filename)) 3514 (gnus-output-to-file filename)))) 3515 filename) 3516 3517(put 'gnus-summary-write-to-file :decode t) 3518(put 'gnus-summary-write-to-file :function 'gnus-summary-save-in-file) 3519(put 'gnus-summary-write-to-file :headers 'gnus-saved-headers) 3520(defun gnus-summary-write-to-file (&optional filename) 3521 "Write this article to a file, overwriting it if the file exists. 3522Optional argument FILENAME specifies file name. 3523The directory to save in defaults to `gnus-article-save-directory'." 3524 (setq filename (gnus-read-save-file-name 3525 "Save %s in file" filename 3526 gnus-file-save-name gnus-newsgroup-name 3527 gnus-current-headers nil 'gnus-newsgroup-last-directory)) 3528 (gnus-summary-save-in-file filename t)) 3529 3530(put 'gnus-summary-save-body-in-file :decode t) 3531(defun gnus-summary-save-body-in-file (&optional filename overwrite) 3532 "Append this article body to a file. 3533Optional argument FILENAME specifies file name. 3534The directory to save in defaults to `gnus-article-save-directory'." 3535 (setq filename (gnus-read-save-file-name 3536 "Save %s body in file" filename 3537 gnus-file-save-name gnus-newsgroup-name 3538 gnus-current-headers 'gnus-newsgroup-last-file)) 3539 (gnus-eval-in-buffer-window gnus-save-article-buffer 3540 (save-excursion 3541 (save-restriction 3542 (widen) 3543 (when (article-goto-body) 3544 (narrow-to-region (point) (point-max))) 3545 (when (and overwrite 3546 (file-exists-p filename)) 3547 (delete-file filename)) 3548 (gnus-output-to-file filename)))) 3549 filename) 3550 3551(put 'gnus-summary-write-body-to-file :decode t) 3552(put 'gnus-summary-write-body-to-file 3553 :function 'gnus-summary-save-body-in-file) 3554(defun gnus-summary-write-body-to-file (&optional filename) 3555 "Write this article body to a file, overwriting it if the file exists. 3556Optional argument FILENAME specifies file name. 3557The directory to save in defaults to `gnus-article-save-directory'." 3558 (setq filename (gnus-read-save-file-name 3559 "Save %s body in file" filename 3560 gnus-file-save-name gnus-newsgroup-name 3561 gnus-current-headers nil 'gnus-newsgroup-last-directory)) 3562 (gnus-summary-save-body-in-file filename t)) 3563 3564(defun gnus-summary-save-in-pipe (&optional command) 3565 "Pipe this article to subprocess." 3566 (setq command 3567 (cond ((and (eq command 'default) 3568 gnus-last-shell-command) 3569 gnus-last-shell-command) 3570 ((stringp command) 3571 command) 3572 (t (read-string 3573 (format 3574 "Shell command on %s: " 3575 (if (and gnus-number-of-articles-to-be-saved 3576 (> gnus-number-of-articles-to-be-saved 1)) 3577 (format "these %d articles" 3578 gnus-number-of-articles-to-be-saved) 3579 "this article")) 3580 gnus-last-shell-command)))) 3581 (when (string-equal command "") 3582 (if gnus-last-shell-command 3583 (setq command gnus-last-shell-command) 3584 (error "A command is required"))) 3585 (gnus-eval-in-buffer-window gnus-article-buffer 3586 (save-restriction 3587 (widen) 3588 (shell-command-on-region (point-min) (point-max) command nil))) 3589 (setq gnus-last-shell-command command)) 3590 3591(defmacro gnus-read-string (prompt &optional initial-contents history 3592 default-value) 3593 "Like `read-string' but allow for older XEmacsen that don't have the 5th arg." 3594 (if (and (featurep 'xemacs) 3595 (< emacs-minor-version 2)) 3596 `(read-string ,prompt ,initial-contents ,history) 3597 `(read-string ,prompt ,initial-contents ,history ,default-value))) 3598 3599(defun gnus-summary-pipe-to-muttprint (&optional command) 3600 "Pipe this article to muttprint." 3601 (setq command (gnus-read-string 3602 "Print using command: " gnus-summary-muttprint-program 3603 nil gnus-summary-muttprint-program)) 3604 (gnus-summary-save-in-pipe command)) 3605 3606;;; Article file names when saving. 3607 3608(defun gnus-capitalize-newsgroup (newsgroup) 3609 "Capitalize NEWSGROUP name." 3610 (when (not (zerop (length newsgroup))) 3611 (concat (char-to-string (upcase (aref newsgroup 0))) 3612 (substring newsgroup 1)))) 3613 3614(defun gnus-Numeric-save-name (newsgroup headers &optional last-file) 3615 "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE. 3616If variable `gnus-use-long-file-name' is non-nil, it is ~/News/News.group/num. 3617Otherwise, it is like ~/News/news/group/num." 3618 (let ((default 3619 (expand-file-name 3620 (concat (if (gnus-use-long-file-name 'not-save) 3621 (gnus-capitalize-newsgroup newsgroup) 3622 (gnus-newsgroup-directory-form newsgroup)) 3623 "/" (int-to-string (mail-header-number headers))) 3624 gnus-article-save-directory))) 3625 (if (and last-file 3626 (string-equal (file-name-directory default) 3627 (file-name-directory last-file)) 3628 (string-match "^[0-9]+$" (file-name-nondirectory last-file))) 3629 default 3630 (or last-file default)))) 3631 3632(defun gnus-numeric-save-name (newsgroup headers &optional last-file) 3633 "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE. 3634If variable `gnus-use-long-file-name' is non-nil, it is 3635~/News/news.group/num. Otherwise, it is like ~/News/news/group/num." 3636 (let ((default 3637 (expand-file-name 3638 (concat (if (gnus-use-long-file-name 'not-save) 3639 newsgroup 3640 (gnus-newsgroup-directory-form newsgroup)) 3641 "/" (int-to-string (mail-header-number headers))) 3642 gnus-article-save-directory))) 3643 (if (and last-file 3644 (string-equal (file-name-directory default) 3645 (file-name-directory last-file)) 3646 (string-match "^[0-9]+$" (file-name-nondirectory last-file))) 3647 default 3648 (or last-file default)))) 3649 3650(defun gnus-plain-save-name (newsgroup headers &optional last-file) 3651 "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE. 3652If variable `gnus-use-long-file-name' is non-nil, it is 3653~/News/news.group. Otherwise, it is like ~/News/news/group/news." 3654 (or last-file 3655 (expand-file-name 3656 (if (gnus-use-long-file-name 'not-save) 3657 newsgroup 3658 (file-relative-name 3659 (expand-file-name "news" (gnus-newsgroup-directory-form newsgroup)) 3660 default-directory)) 3661 gnus-article-save-directory))) 3662 3663(defun gnus-sender-save-name (newsgroup headers &optional last-file) 3664 "Generate file name from sender." 3665 (let ((from (mail-header-from headers))) 3666 (expand-file-name 3667 (if (and from (string-match "\\([^ <]+\\)@" from)) 3668 (match-string 1 from) 3669 "nobody") 3670 gnus-article-save-directory))) 3671 3672(defun article-verify-x-pgp-sig () 3673 "Verify X-PGP-Sig." 3674 (interactive) 3675 (if (gnus-buffer-live-p gnus-original-article-buffer) 3676 (let ((sig (with-current-buffer gnus-original-article-buffer 3677 (gnus-fetch-field "X-PGP-Sig"))) 3678 items info headers) 3679 (when (and sig 3680 mml2015-use 3681 (mml2015-clear-verify-function)) 3682 (with-temp-buffer 3683 (insert-buffer-substring gnus-original-article-buffer) 3684 (setq items (split-string sig)) 3685 (message-narrow-to-head) 3686 (let ((inhibit-point-motion-hooks t) 3687 (case-fold-search t)) 3688 ;; Don't verify multiple headers. 3689 (setq headers (mapconcat (lambda (header) 3690 (concat header ": " 3691 (mail-fetch-field header) 3692 "\n")) 3693 (split-string (nth 1 items) ",") ""))) 3694 (delete-region (point-min) (point-max)) 3695 (insert "-----BEGIN PGP SIGNED MESSAGE-----\n\n") 3696 (insert "X-Signed-Headers: " (nth 1 items) "\n") 3697 (insert headers) 3698 (widen) 3699 (forward-line) 3700 (while (not (eobp)) 3701 (if (looking-at "^-") 3702 (insert "- ")) 3703 (forward-line)) 3704 (insert "\n-----BEGIN PGP SIGNATURE-----\n") 3705 (insert "Version: " (car items) "\n\n") 3706 (insert (mapconcat 'identity (cddr items) "\n")) 3707 (insert "\n-----END PGP SIGNATURE-----\n") 3708 (let ((mm-security-handle (list (format "multipart/signed")))) 3709 (mml2015-clean-buffer) 3710 (let ((coding-system-for-write (or gnus-newsgroup-charset 3711 'iso-8859-1))) 3712 (funcall (mml2015-clear-verify-function))) 3713 (setq info 3714 (or (mm-handle-multipart-ctl-parameter 3715 mm-security-handle 'gnus-details) 3716 (mm-handle-multipart-ctl-parameter 3717 mm-security-handle 'gnus-info))))) 3718 (when info 3719 (let ((inhibit-read-only t) bface eface) 3720 (save-restriction 3721 (message-narrow-to-head) 3722 (goto-char (point-max)) 3723 (forward-line -1) 3724 (setq bface (get-text-property (gnus-point-at-bol) 'face) 3725 eface (get-text-property (1- (gnus-point-at-eol)) 'face)) 3726 (message-remove-header "X-Gnus-PGP-Verify") 3727 (if (re-search-forward "^X-PGP-Sig:" nil t) 3728 (forward-line) 3729 (goto-char (point-max))) 3730 (narrow-to-region (point) (point)) 3731 (insert "X-Gnus-PGP-Verify: " info "\n") 3732 (goto-char (point-min)) 3733 (forward-line) 3734 (while (not (eobp)) 3735 (if (not (looking-at "^[ \t]")) 3736 (insert " ")) 3737 (forward-line)) 3738 ;; Do highlighting. 3739 (goto-char (point-min)) 3740 (when (looking-at "\\([^:]+\\): *") 3741 (put-text-property (match-beginning 1) (1+ (match-end 1)) 3742 'face bface) 3743 (put-text-property (match-end 0) (point-max) 3744 'face eface))))))))) 3745 3746(defun article-verify-cancel-lock () 3747 "Verify Cancel-Lock header." 3748 (interactive) 3749 (if (gnus-buffer-live-p gnus-original-article-buffer) 3750 (canlock-verify gnus-original-article-buffer))) 3751 3752(eval-and-compile 3753 (mapcar 3754 (lambda (func) 3755 (let (afunc gfunc) 3756 (if (consp func) 3757 (setq afunc (car func) 3758 gfunc (cdr func)) 3759 (setq afunc func 3760 gfunc (intern (format "gnus-%s" func)))) 3761 (defalias gfunc 3762 (when (fboundp afunc) 3763 `(lambda (&optional interactive &rest args) 3764 ,(documentation afunc t) 3765 (interactive (list t)) 3766 (save-excursion 3767 (set-buffer gnus-article-buffer) 3768 (if interactive 3769 (call-interactively ',afunc) 3770 (apply ',afunc args)))))))) 3771 '(article-hide-headers 3772 article-verify-x-pgp-sig 3773 article-verify-cancel-lock 3774 article-hide-boring-headers 3775 article-treat-overstrike 3776 article-fill-long-lines 3777 article-capitalize-sentences 3778 article-remove-cr 3779 article-remove-leading-whitespace 3780 article-display-x-face 3781 article-display-face 3782 article-de-quoted-unreadable 3783 article-de-base64-unreadable 3784 article-decode-HZ 3785 article-wash-html 3786 article-unsplit-urls 3787 article-hide-list-identifiers 3788 article-strip-banner 3789 article-babel 3790 article-hide-pem 3791 article-hide-signature 3792 article-strip-headers-in-body 3793 article-remove-trailing-blank-lines 3794 article-strip-leading-blank-lines 3795 article-strip-multiple-blank-lines 3796 article-strip-leading-space 3797 article-strip-trailing-space 3798 article-strip-blank-lines 3799 article-strip-all-blank-lines 3800 article-date-local 3801 article-date-english 3802 article-date-iso8601 3803 article-date-original 3804 article-date-ut 3805 article-decode-mime-words 3806 article-decode-charset 3807 article-decode-encoded-words 3808 article-date-user 3809 article-date-lapsed 3810 article-emphasize 3811 article-treat-dumbquotes 3812 article-normalize-headers 3813;; (article-show-all . gnus-article-show-all-headers) 3814 ))) 3815 3816;;; 3817;;; Gnus article mode 3818;;; 3819 3820(put 'gnus-article-mode 'mode-class 'special) 3821 3822(set-keymap-parent gnus-article-mode-map widget-keymap) 3823 3824(gnus-define-keys gnus-article-mode-map 3825 " " gnus-article-goto-next-page 3826 "\177" gnus-article-goto-prev-page 3827 [delete] gnus-article-goto-prev-page 3828 [backspace] gnus-article-goto-prev-page 3829 "\C-c^" gnus-article-refer-article 3830 "h" gnus-article-show-summary 3831 "s" gnus-article-show-summary 3832 "\C-c\C-m" gnus-article-mail 3833 "?" gnus-article-describe-briefly 3834 "e" gnus-summary-edit-article 3835 "<" beginning-of-buffer 3836 ">" end-of-buffer 3837 "\C-c\C-i" gnus-info-find-node 3838 "\C-c\C-b" gnus-bug 3839 "R" gnus-article-reply-with-original 3840 "F" gnus-article-followup-with-original 3841 "\C-hk" gnus-article-describe-key 3842 "\C-hc" gnus-article-describe-key-briefly 3843 3844 "\C-d" gnus-article-read-summary-keys 3845 "\M-*" gnus-article-read-summary-keys 3846 "\M-#" gnus-article-read-summary-keys 3847 "\M-^" gnus-article-read-summary-keys 3848 "\M-g" gnus-article-read-summary-keys) 3849 3850(substitute-key-definition 3851 'undefined 'gnus-article-read-summary-keys gnus-article-mode-map) 3852 3853(defun gnus-article-make-menu-bar () 3854 (unless (boundp 'gnus-article-commands-menu) 3855 (gnus-summary-make-menu-bar)) 3856 (gnus-turn-off-edit-menu 'article) 3857 (unless (boundp 'gnus-article-article-menu) 3858 (easy-menu-define 3859 gnus-article-article-menu gnus-article-mode-map "" 3860 '("Article" 3861 ["Scroll forwards" gnus-article-goto-next-page t] 3862 ["Scroll backwards" gnus-article-goto-prev-page t] 3863 ["Show summary" gnus-article-show-summary t] 3864 ["Fetch Message-ID at point" gnus-article-refer-article t] 3865 ["Mail to address at point" gnus-article-mail t] 3866 ["Send a bug report" gnus-bug t])) 3867 3868 (easy-menu-define 3869 gnus-article-treatment-menu gnus-article-mode-map "" 3870 ;; Fixme: this should use :active (and maybe :visible). 3871 '("Treatment" 3872 ["Hide headers" gnus-article-hide-headers t] 3873 ["Hide signature" gnus-article-hide-signature t] 3874 ["Hide citation" gnus-article-hide-citation t] 3875 ["Treat overstrike" gnus-article-treat-overstrike t] 3876 ["Remove carriage return" gnus-article-remove-cr t] 3877 ["Remove leading whitespace" gnus-article-remove-leading-whitespace t] 3878 ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t] 3879 ["Remove base64" gnus-article-de-base64-unreadable t] 3880 ["Treat html" gnus-article-wash-html t] 3881 ["Remove newlines from within URLs" gnus-article-unsplit-urls t] 3882 ["Decode HZ" gnus-article-decode-HZ t])) 3883 3884 ;; Note "Commands" menu is defined in gnus-sum.el for consistency 3885 3886 ;; Note "Post" menu is defined in gnus-sum.el for consistency 3887 3888 (gnus-run-hooks 'gnus-article-menu-hook))) 3889 3890(defun gnus-article-mode () 3891 "Major mode for displaying an article. 3892 3893All normal editing commands are switched off. 3894 3895The following commands are available in addition to all summary mode 3896commands: 3897\\<gnus-article-mode-map> 3898\\[gnus-article-next-page]\t Scroll the article one page forwards 3899\\[gnus-article-prev-page]\t Scroll the article one page backwards 3900\\[gnus-article-refer-article]\t Go to the article referred to by an article id near point 3901\\[gnus-article-show-summary]\t Display the summary buffer 3902\\[gnus-article-mail]\t Send a reply to the address near point 3903\\[gnus-article-describe-briefly]\t Describe the current mode briefly 3904\\[gnus-info-find-node]\t Go to the Gnus info node" 3905 (interactive) 3906 (kill-all-local-variables) 3907 (gnus-simplify-mode-line) 3908 (setq mode-name "Article") 3909 (setq major-mode 'gnus-article-mode) 3910 (make-local-variable 'minor-mode-alist) 3911 (use-local-map gnus-article-mode-map) 3912 (when (gnus-visual-p 'article-menu 'menu) 3913 (gnus-article-make-menu-bar) 3914 (when gnus-summary-tool-bar-map 3915 (set (make-local-variable 'tool-bar-map) gnus-summary-tool-bar-map))) 3916 (gnus-update-format-specifications nil 'article-mode) 3917 (set (make-local-variable 'page-delimiter) gnus-page-delimiter) 3918 (set (make-local-variable 'gnus-page-broken) nil) 3919 (make-local-variable 'gnus-button-marker-list) 3920 (make-local-variable 'gnus-article-current-summary) 3921 (make-local-variable 'gnus-article-mime-handles) 3922 (make-local-variable 'gnus-article-decoded-p) 3923 (make-local-variable 'gnus-article-mime-handle-alist) 3924 (make-local-variable 'gnus-article-wash-types) 3925 (make-local-variable 'gnus-article-image-alist) 3926 (make-local-variable 'gnus-article-charset) 3927 (make-local-variable 'gnus-article-ignored-charsets) 3928 ;; Prevent recent Emacsen from displaying non-break space as "\ ". 3929 (set (make-local-variable 'nobreak-char-display) nil) 3930 (setq cursor-in-non-selected-windows nil) 3931 (gnus-set-default-directory) 3932 (buffer-disable-undo) 3933 (setq buffer-read-only t) 3934 (set-syntax-table gnus-article-mode-syntax-table) 3935 (mm-enable-multibyte) 3936 (gnus-run-mode-hooks 'gnus-article-mode-hook)) 3937 3938;; Internal variables. Are `gnus-button-regexp' and `gnus-button-last' used 3939;; at all? 3940(defvar gnus-button-regexp nil) 3941(defvar gnus-button-marker-list nil 3942 "Regexp matching any of the regexps from `gnus-button-alist'.") 3943(defvar gnus-button-last nil 3944 "The value of `gnus-button-alist' when `gnus-button-regexp' was build.") 3945 3946(defun gnus-article-setup-buffer () 3947 "Initialize the article buffer." 3948 (let* ((name (if gnus-single-article-buffer "*Article*" 3949 (concat "*Article " gnus-newsgroup-name "*"))) 3950 (original 3951 (progn (string-match "\\*Article" name) 3952 (concat " *Original Article" 3953 (substring name (match-end 0)))))) 3954 (setq gnus-article-buffer name) 3955 (setq gnus-original-article-buffer original) 3956 (setq gnus-article-mime-handle-alist nil) 3957 ;; This might be a variable local to the summary buffer. 3958 (unless gnus-single-article-buffer 3959 (save-excursion 3960 (set-buffer gnus-summary-buffer) 3961 (setq gnus-article-buffer name) 3962 (setq gnus-original-article-buffer original) 3963 (gnus-set-global-variables))) 3964 (gnus-article-setup-highlight-words) 3965 ;; Init original article buffer. 3966 (save-excursion 3967 (set-buffer (gnus-get-buffer-create gnus-original-article-buffer)) 3968 (mm-enable-multibyte) 3969 (setq major-mode 'gnus-original-article-mode) 3970 (make-local-variable 'gnus-original-article)) 3971 (if (and (get-buffer name) 3972 (with-current-buffer name 3973 (if gnus-article-edit-mode 3974 (if (y-or-n-p "Article mode edit in progress; discard? ") 3975 (progn 3976 (set-buffer-modified-p nil) 3977 (gnus-kill-buffer name) 3978 (message "") 3979 nil) 3980 (error "Action aborted")) 3981 t))) 3982 (save-excursion 3983 (set-buffer name) 3984 (set (make-local-variable 'gnus-article-edit-mode) nil) 3985 (when gnus-article-mime-handles 3986 (mm-destroy-parts gnus-article-mime-handles) 3987 (setq gnus-article-mime-handles nil)) 3988 ;; Set it to nil in article-buffer! 3989 (setq gnus-article-mime-handle-alist nil) 3990 (buffer-disable-undo) 3991 (setq buffer-read-only t) 3992 ;; This list just keeps growing if we don't reset it. 3993 (setq gnus-button-marker-list nil) 3994 (unless (eq major-mode 'gnus-article-mode) 3995 (gnus-article-mode)) 3996 (current-buffer)) 3997 (save-excursion 3998 (set-buffer (gnus-get-buffer-create name)) 3999 (gnus-article-mode) 4000 (make-local-variable 'gnus-summary-buffer) 4001 (gnus-summary-set-local-parameters gnus-newsgroup-name) 4002 (current-buffer))))) 4003 4004;; Set article window start at LINE, where LINE is the number of lines 4005;; from the head of the article. 4006(defun gnus-article-set-window-start (&optional line) 4007 (set-window-start 4008 (gnus-get-buffer-window gnus-article-buffer t) 4009 (save-excursion 4010 (set-buffer gnus-article-buffer) 4011 (goto-char (point-min)) 4012 (if (not line) 4013 (point-min) 4014 (gnus-message 6 "Moved to bookmark") 4015 (search-forward "\n\n" nil t) 4016 (forward-line line) 4017 (point))))) 4018 4019(defun gnus-article-prepare (article &optional all-headers header) 4020 "Prepare ARTICLE in article mode buffer. 4021ARTICLE should either be an article number or a Message-ID. 4022If ARTICLE is an id, HEADER should be the article headers. 4023If ALL-HEADERS is non-nil, no headers are hidden." 4024 (save-excursion 4025 ;; Make sure we start in a summary buffer. 4026 (unless (eq major-mode 'gnus-summary-mode) 4027 (set-buffer gnus-summary-buffer)) 4028 (setq gnus-summary-buffer (current-buffer)) 4029 (let* ((gnus-article (if header (mail-header-number header) article)) 4030 (summary-buffer (current-buffer)) 4031 (gnus-tmp-internal-hook gnus-article-internal-prepare-hook) 4032 (group gnus-newsgroup-name) 4033 result) 4034 (save-excursion 4035 (gnus-article-setup-buffer) 4036 (set-buffer gnus-article-buffer) 4037 ;; Deactivate active regions. 4038 (when (and (boundp 'transient-mark-mode) 4039 transient-mark-mode) 4040 (setq mark-active nil)) 4041 (if (not (setq result (let ((inhibit-read-only t)) 4042 (gnus-request-article-this-buffer 4043 article group)))) 4044 ;; There is no such article. 4045 (save-excursion 4046 (when (and (numberp article) 4047 (not (memq article gnus-newsgroup-sparse))) 4048 (setq gnus-article-current 4049 (cons gnus-newsgroup-name article)) 4050 (set-buffer gnus-summary-buffer) 4051 (setq gnus-current-article article) 4052 (if (and (memq article gnus-newsgroup-undownloaded) 4053 (not (gnus-online (gnus-find-method-for-group 4054 gnus-newsgroup-name)))) 4055 (progn 4056 (gnus-summary-set-agent-mark article) 4057 (message "Message marked for downloading")) 4058 (gnus-summary-mark-article article gnus-canceled-mark) 4059 (unless (memq article gnus-newsgroup-sparse) 4060 (gnus-error 1 "No such article (may have expired or been canceled)"))))) 4061 (if (or (eq result 'pseudo) 4062 (eq result 'nneething)) 4063 (progn 4064 (save-excursion 4065 (set-buffer summary-buffer) 4066 (push article gnus-newsgroup-history) 4067 (setq gnus-last-article gnus-current-article 4068 gnus-current-article 0 4069 gnus-current-headers nil 4070 gnus-article-current nil) 4071 (if (eq result 'nneething) 4072 (gnus-configure-windows 'summary) 4073 (gnus-configure-windows 'article)) 4074 (gnus-set-global-variables)) 4075 (let ((gnus-article-mime-handle-alist-1 4076 gnus-article-mime-handle-alist)) 4077 (gnus-set-mode-line 'article))) 4078 ;; The result from the `request' was an actual article - 4079 ;; or at least some text that is now displayed in the 4080 ;; article buffer. 4081 (when (and (numberp article) 4082 (not (eq article gnus-current-article))) 4083 ;; Seems like a new article has been selected. 4084 ;; `gnus-current-article' must be an article number. 4085 (save-excursion 4086 (set-buffer summary-buffer) 4087 (push article gnus-newsgroup-history) 4088 (setq gnus-last-article gnus-current-article 4089 gnus-current-article article 4090 gnus-current-headers 4091 (gnus-summary-article-header gnus-current-article) 4092 gnus-article-current 4093 (cons gnus-newsgroup-name gnus-current-article)) 4094 (unless (vectorp gnus-current-headers) 4095 (setq gnus-current-headers nil)) 4096 (gnus-summary-goto-subject gnus-current-article) 4097 (when (gnus-summary-show-thread) 4098 ;; If the summary buffer really was folded, the 4099 ;; previous goto may not actually have gone to 4100 ;; the right article, but the thread root instead. 4101 ;; So we go again. 4102 (gnus-summary-goto-subject gnus-current-article)) 4103 (gnus-run-hooks 'gnus-mark-article-hook) 4104 (gnus-set-mode-line 'summary) 4105 (when (gnus-visual-p 'article-highlight 'highlight) 4106 (gnus-run-hooks 'gnus-visual-mark-article-hook)) 4107 ;; Set the global newsgroup variables here. 4108 (gnus-set-global-variables) 4109 (setq gnus-have-all-headers 4110 (or all-headers gnus-show-all-headers)))) 4111 (save-excursion 4112 (gnus-configure-windows 'article)) 4113 (when (or (numberp article) 4114 (stringp article)) 4115 (gnus-article-prepare-display) 4116 ;; Do page break. 4117 (goto-char (point-min)) 4118 (when gnus-break-pages 4119 (gnus-narrow-to-page))) 4120 (let ((gnus-article-mime-handle-alist-1 4121 gnus-article-mime-handle-alist)) 4122 (gnus-set-mode-line 'article)) 4123 (article-goto-body) 4124 (unless (bobp) 4125 (forward-line -1)) 4126 (set-window-point (get-buffer-window (current-buffer)) (point)) 4127 (gnus-configure-windows 'article) 4128 t)))))) 4129 4130;;;###autoload 4131(defun gnus-article-prepare-display () 4132 "Make the current buffer look like a nice article." 4133 ;; Hooks for getting information from the article. 4134 ;; This hook must be called before being narrowed. 4135 (let ((gnus-article-buffer (current-buffer)) 4136 buffer-read-only 4137 (inhibit-read-only t)) 4138 (unless (eq major-mode 'gnus-article-mode) 4139 (gnus-article-mode)) 4140 (setq buffer-read-only nil 4141 gnus-article-wash-types nil 4142 gnus-article-image-alist nil) 4143 (gnus-run-hooks 'gnus-tmp-internal-hook) 4144 (when gnus-display-mime-function 4145 (funcall gnus-display-mime-function)) 4146 (gnus-run-hooks 'gnus-article-prepare-hook))) 4147 4148;;; 4149;;; Gnus MIME viewing functions 4150;;; 4151 4152(defvar gnus-mime-button-line-format "%{%([%p. %d%T]%)%}%e\n" 4153 "Format of the MIME buttons. 4154 4155Valid specifiers include: 4156%t The MIME type 4157%T MIME type, along with additional info 4158%n The `name' parameter 4159%d The description, if any 4160%l The length of the encoded part 4161%p The part identifier number 4162%e Dots if the part isn't displayed 4163 4164General format specifiers can also be used. See Info node 4165`(gnus)Formatting Variables'.") 4166 4167(defvar gnus-mime-button-line-format-alist 4168 '((?t gnus-tmp-type ?s) 4169 (?T gnus-tmp-type-long ?s) 4170 (?n gnus-tmp-name ?s) 4171 (?d gnus-tmp-description ?s) 4172 (?p gnus-tmp-id ?s) 4173 (?l gnus-tmp-length ?d) 4174 (?e gnus-tmp-dots ?s))) 4175 4176(defvar gnus-mime-button-commands 4177 '((gnus-article-press-button "\r" "Toggle Display") 4178 (gnus-mime-view-part "v" "View Interactively...") 4179 (gnus-mime-view-part-as-type "t" "View As Type...") 4180 (gnus-mime-view-part-as-charset "C" "View As charset...") 4181 (gnus-mime-save-part "o" "Save...") 4182 (gnus-mime-save-part-and-strip "\C-o" "Save and Strip") 4183 (gnus-mime-delete-part "d" "Delete part") 4184 (gnus-mime-copy-part "c" "View As Text, In Other Buffer") 4185 (gnus-mime-inline-part "i" "View As Text, In This Buffer") 4186 (gnus-mime-view-part-internally "E" "View Internally") 4187 (gnus-mime-view-part-externally "e" "View Externally") 4188 (gnus-mime-print-part "p" "Print") 4189 (gnus-mime-pipe-part "|" "Pipe To Command...") 4190 (gnus-mime-action-on-part "." "Take action on the part..."))) 4191 4192(defun gnus-article-mime-part-status () 4193 (if gnus-article-mime-handle-alist-1 4194 (if (eq 1 (length gnus-article-mime-handle-alist-1)) 4195 " (1 part)" 4196 (format " (%d parts)" (length gnus-article-mime-handle-alist-1))) 4197 "")) 4198 4199(defvar gnus-mime-button-map 4200 (let ((map (make-sparse-keymap))) 4201 (unless (>= (string-to-number emacs-version) 21) 4202 ;; XEmacs doesn't care. 4203 (set-keymap-parent map gnus-article-mode-map)) 4204 (define-key map gnus-mouse-2 'gnus-article-push-button) 4205 (define-key map gnus-down-mouse-3 'gnus-mime-button-menu) 4206 (dolist (c gnus-mime-button-commands) 4207 (define-key map (cadr c) (car c))) 4208 map)) 4209 4210(easy-menu-define 4211 gnus-mime-button-menu gnus-mime-button-map "MIME button menu." 4212 `("MIME Part" 4213 ,@(mapcar (lambda (c) 4214 (vector (caddr c) (car c) :enable t)) 4215 gnus-mime-button-commands))) 4216 4217(eval-when-compile 4218 (define-compiler-macro popup-menu (&whole form 4219 menu &optional position prefix) 4220 (if (and (fboundp 'popup-menu) 4221 (not (memq 'popup-menu (assoc "lmenu" load-history)))) 4222 form 4223 ;; Gnus is probably running under Emacs 20. 4224 `(let* ((menu (cdr ,menu)) 4225 (response (x-popup-menu 4226 t (list (car menu) 4227 (cons "" (mapcar (lambda (c) 4228 (cons (caddr c) (car c))) 4229 (cdr menu))))))) 4230 (if response 4231 (call-interactively (nth 3 (assq response menu)))))))) 4232 4233(defun gnus-mime-button-menu (event prefix) 4234 "Construct a context-sensitive menu of MIME commands." 4235 (interactive "e\nP") 4236 (save-window-excursion 4237 (let ((pos (event-start event))) 4238 (select-window (posn-window pos)) 4239 (goto-char (posn-point pos)) 4240 (gnus-article-check-buffer) 4241 (popup-menu gnus-mime-button-menu nil prefix)))) 4242 4243(defun gnus-mime-view-all-parts (&optional handles) 4244 "View all the MIME parts." 4245 (interactive) 4246 (save-current-buffer 4247 (set-buffer gnus-article-buffer) 4248 (let ((handles (or handles gnus-article-mime-handles)) 4249 (mail-parse-charset gnus-newsgroup-charset) 4250 (mail-parse-ignored-charsets 4251 (with-current-buffer gnus-summary-buffer 4252 gnus-newsgroup-ignored-charsets))) 4253 (when handles 4254 (mm-remove-parts handles) 4255 (goto-char (point-min)) 4256 (or (search-forward "\n\n") (goto-char (point-max))) 4257 (let ((inhibit-read-only t)) 4258 (delete-region (point) (point-max)) 4259 (mm-display-parts handles)))))) 4260 4261(defun gnus-mime-save-part-and-strip () 4262 "Save the MIME part under point then replace it with an external body." 4263 (interactive) 4264 (gnus-article-check-buffer) 4265 (when (gnus-group-read-only-p) 4266 (error "The current group does not support deleting of parts")) 4267 (when (mm-complicated-handles gnus-article-mime-handles) 4268 (error "\ 4269The current article has a complicated MIME structure, giving up...")) 4270 (when (gnus-yes-or-no-p "\ 4271Deleting parts may malfunction or destroy the article; continue? ") 4272 (let* ((data (get-text-property (point) 'gnus-data)) 4273 file param 4274 (handles gnus-article-mime-handles)) 4275 (setq file (and data (mm-save-part data))) 4276 (when file 4277 (with-current-buffer (mm-handle-buffer data) 4278 (erase-buffer) 4279 (insert "Content-Type: " (mm-handle-media-type data)) 4280 (mml-insert-parameter-string (cdr (mm-handle-type data)) 4281 '(charset)) 4282 ;; Add a filename for the sake of saving the part again. 4283 (mml-insert-parameter 4284 (mail-header-encode-parameter "name" (file-name-nondirectory file))) 4285 (insert "\n") 4286 (insert "Content-ID: " (message-make-message-id) "\n") 4287 (insert "Content-Transfer-Encoding: binary\n") 4288 (insert "\n")) 4289 (setcdr data 4290 (cdr (mm-make-handle nil 4291 `("message/external-body" 4292 (access-type . "LOCAL-FILE") 4293 (name . ,file))))) 4294 (set-buffer gnus-summary-buffer) 4295 (gnus-article-edit-article 4296 `(lambda () 4297 (erase-buffer) 4298 (let ((mail-parse-charset (or gnus-article-charset 4299 ',gnus-newsgroup-charset)) 4300 (mail-parse-ignored-charsets 4301 (or gnus-article-ignored-charsets 4302 ',gnus-newsgroup-ignored-charsets)) 4303 (mbl mml-buffer-list)) 4304 (setq mml-buffer-list nil) 4305 (insert-buffer-substring gnus-original-article-buffer) 4306 (mime-to-mml ',handles) 4307 (setq gnus-article-mime-handles nil) 4308 (let ((mbl1 mml-buffer-list)) 4309 (setq mml-buffer-list mbl) 4310 (set (make-local-variable 'mml-buffer-list) mbl1)) 4311 (gnus-make-local-hook 'kill-buffer-hook) 4312 (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t))) 4313 `(lambda (no-highlight) 4314 (let ((mail-parse-charset (or gnus-article-charset 4315 ',gnus-newsgroup-charset)) 4316 (message-options message-options) 4317 (message-options-set-recipient) 4318 (mail-parse-ignored-charsets 4319 (or gnus-article-ignored-charsets 4320 ',gnus-newsgroup-ignored-charsets))) 4321 (mml-to-mime) 4322 (mml-destroy-buffers) 4323 (remove-hook 'kill-buffer-hook 4324 'mml-destroy-buffers t) 4325 (kill-local-variable 'mml-buffer-list)) 4326 (gnus-summary-edit-article-done 4327 ,(or (mail-header-references gnus-current-headers) "") 4328 ,(gnus-group-read-only-p) 4329 ,gnus-summary-buffer no-highlight))))))) 4330 4331(defun gnus-mime-delete-part () 4332 "Delete the MIME part under point. 4333Replace it with some information about the removed part." 4334 (interactive) 4335 (gnus-article-check-buffer) 4336 (when (gnus-group-read-only-p) 4337 (error "The current group does not support deleting of parts")) 4338 (when (mm-complicated-handles gnus-article-mime-handles) 4339 (error "\ 4340The current article has a complicated MIME structure, giving up...")) 4341 (when (gnus-yes-or-no-p "\ 4342Deleting parts may malfunction or destroy the article; continue? ") 4343 (let* ((data (get-text-property (point) 'gnus-data)) 4344 (handles gnus-article-mime-handles) 4345 (none "(none)") 4346 (description 4347 (mail-decode-encoded-word-string (or (mm-handle-description data) 4348 none))) 4349 (filename 4350 (or (mail-content-type-get (mm-handle-disposition data) 'filename) 4351 none)) 4352 (type (mm-handle-media-type data))) 4353 (unless data 4354 (error "No MIME part under point")) 4355 (with-current-buffer (mm-handle-buffer data) 4356 (let ((bsize (format "%s" (buffer-size)))) 4357 (erase-buffer) 4358 (insert 4359 (concat 4360 ",----\n" 4361 "| The following attachment has been deleted:\n" 4362 "|\n" 4363 "| Type: " type "\n" 4364 "| Filename: " filename "\n" 4365 "| Size (encoded): " bsize " Byte\n" 4366 "| Description: " description "\n" 4367 "`----\n")) 4368 (setcdr data 4369 (cdr (mm-make-handle 4370 nil `("text/plain") nil nil 4371 (list "attachment") 4372 (format "Deleted attachment (%s bytes)" bsize)))))) 4373 (set-buffer gnus-summary-buffer) 4374 ;; FIXME: maybe some of the following code (borrowed from 4375 ;; `gnus-mime-save-part-and-strip') isn't necessary? 4376 (gnus-article-edit-article 4377 `(lambda () 4378 (erase-buffer) 4379 (let ((mail-parse-charset (or gnus-article-charset 4380 ',gnus-newsgroup-charset)) 4381 (mail-parse-ignored-charsets 4382 (or gnus-article-ignored-charsets 4383 ',gnus-newsgroup-ignored-charsets)) 4384 (mbl mml-buffer-list)) 4385 (setq mml-buffer-list nil) 4386 (insert-buffer-substring gnus-original-article-buffer) 4387 (mime-to-mml ',handles) 4388 (setq gnus-article-mime-handles nil) 4389 (let ((mbl1 mml-buffer-list)) 4390 (setq mml-buffer-list mbl) 4391 (set (make-local-variable 'mml-buffer-list) mbl1)) 4392 (gnus-make-local-hook 'kill-buffer-hook) 4393 (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t))) 4394 `(lambda (no-highlight) 4395 (let ((mail-parse-charset (or gnus-article-charset 4396 ',gnus-newsgroup-charset)) 4397 (message-options message-options) 4398 (message-options-set-recipient) 4399 (mail-parse-ignored-charsets 4400 (or gnus-article-ignored-charsets 4401 ',gnus-newsgroup-ignored-charsets))) 4402 (mml-to-mime) 4403 (mml-destroy-buffers) 4404 (remove-hook 'kill-buffer-hook 4405 'mml-destroy-buffers t) 4406 (kill-local-variable 'mml-buffer-list)) 4407 (gnus-summary-edit-article-done 4408 ,(or (mail-header-references gnus-current-headers) "") 4409 ,(gnus-group-read-only-p) 4410 ,gnus-summary-buffer no-highlight))))) 4411 ;; Not in `gnus-mime-save-part-and-strip': 4412 (gnus-article-edit-done) 4413 (gnus-summary-expand-window) 4414 (gnus-summary-show-article)) 4415 4416(defun gnus-mime-save-part () 4417 "Save the MIME part under point." 4418 (interactive) 4419 (gnus-article-check-buffer) 4420 (let ((data (get-text-property (point) 'gnus-data))) 4421 (when data 4422 (mm-save-part data)))) 4423 4424(defun gnus-mime-pipe-part () 4425 "Pipe the MIME part under point to a process." 4426 (interactive) 4427 (gnus-article-check-buffer) 4428 (let ((data (get-text-property (point) 'gnus-data))) 4429 (when data 4430 (mm-pipe-part data)))) 4431 4432(defun gnus-mime-view-part () 4433 "Interactively choose a viewing method for the MIME part under point." 4434 (interactive) 4435 (gnus-article-check-buffer) 4436 (let ((data (get-text-property (point) 'gnus-data))) 4437 (when data 4438 (setq gnus-article-mime-handles 4439 (mm-merge-handles 4440 gnus-article-mime-handles (setq data (copy-sequence data)))) 4441 (mm-interactively-view-part data)))) 4442 4443(defun gnus-mime-view-part-as-type-internal () 4444 (gnus-article-check-buffer) 4445 (let* ((handle (get-text-property (point) 'gnus-data)) 4446 (name (or 4447 ;; Content-Type: foo/bar; name=... 4448 (mail-content-type-get (mm-handle-type handle) 'name) 4449 ;; Content-Disposition: attachment; filename=... 4450 (cdr (assq 'filename (cdr (mm-handle-disposition handle)))))) 4451 (def-type (and name (mm-default-file-encoding name)))) 4452 (and def-type (cons def-type 0)))) 4453 4454(defun gnus-mime-view-part-as-type (&optional mime-type pred) 4455 "Choose a MIME media type, and view the part as such. 4456If non-nil, PRED is a predicate to use during completion to limit the 4457available media-types." 4458 (interactive) 4459 (unless mime-type 4460 (setq mime-type 4461 (let ((default (gnus-mime-view-part-as-type-internal))) 4462 (completing-read 4463 (format "View as MIME type (default %s): " 4464 (car default)) 4465 (mapcar #'list (mailcap-mime-types)) 4466 pred nil nil nil 4467 (car default))))) 4468 (gnus-article-check-buffer) 4469 (let ((handle (get-text-property (point) 'gnus-data))) 4470 (when handle 4471 (when (equal (mm-handle-media-type handle) "message/external-body") 4472 (unless (mm-handle-cache handle) 4473 (mm-extern-cache-contents handle)) 4474 (setq handle (mm-handle-cache handle))) 4475 (setq handle 4476 (mm-make-handle (mm-handle-buffer handle) 4477 (cons mime-type (cdr (mm-handle-type handle))) 4478 (mm-handle-encoding handle) 4479 (mm-handle-undisplayer handle) 4480 (mm-handle-disposition handle) 4481 (mm-handle-description handle) 4482 nil 4483 (mm-handle-id handle))) 4484 (setq gnus-article-mime-handles 4485 (mm-merge-handles gnus-article-mime-handles handle)) 4486 (gnus-mm-display-part handle)))) 4487 4488(eval-when-compile 4489 (require 'jka-compr)) 4490 4491;; jka-compr.el uses a "sh -c" to direct stderr to err-file, but these days 4492;; emacs can do that itself. 4493;; 4494(defun gnus-mime-jka-compr-maybe-uncompress () 4495 "Uncompress the current buffer if `auto-compression-mode' is enabled. 4496The uncompress method used is derived from `buffer-file-name'." 4497 (when (and (fboundp 'jka-compr-installed-p) 4498 (jka-compr-installed-p)) 4499 (let ((info (jka-compr-get-compression-info buffer-file-name))) 4500 (when info 4501 (let ((basename (file-name-nondirectory buffer-file-name)) 4502 (args (jka-compr-info-uncompress-args info)) 4503 (prog (jka-compr-info-uncompress-program info)) 4504 (message (jka-compr-info-uncompress-message info)) 4505 (err-file (jka-compr-make-temp-name))) 4506 (if message 4507 (message "%s %s..." message basename)) 4508 (unwind-protect 4509 (unless (memq (apply 'call-process-region 4510 (point-min) (point-max) 4511 prog 4512 t (list t err-file) nil 4513 args) 4514 jka-compr-acceptable-retval-list) 4515 (jka-compr-error prog args basename message err-file)) 4516 (jka-compr-delete-temp-file err-file))))))) 4517 4518(defun gnus-mime-copy-part (&optional handle) 4519 "Put the MIME part under point into a new buffer. 4520If `auto-compression-mode' is enabled, compressed files like .gz and .bz2 4521are decompressed." 4522 (interactive) 4523 (gnus-article-check-buffer) 4524 (let* ((handle (or handle (get-text-property (point) 'gnus-data))) 4525 (contents (and handle (mm-get-part handle))) 4526 (base (and handle 4527 (file-name-nondirectory 4528 (or 4529 (mail-content-type-get (mm-handle-type handle) 'name) 4530 (mail-content-type-get (mm-handle-disposition handle) 4531 'filename) 4532 "*decoded*")))) 4533 (buffer (and base (generate-new-buffer base)))) 4534 (when contents 4535 (switch-to-buffer buffer) 4536 (insert contents) 4537 ;; We do it this way to make `normal-mode' set the appropriate mode. 4538 (unwind-protect 4539 (progn 4540 (setq buffer-file-name (expand-file-name base)) 4541 (gnus-mime-jka-compr-maybe-uncompress) 4542 (normal-mode)) 4543 (setq buffer-file-name nil)) 4544 (goto-char (point-min))))) 4545 4546(defun gnus-mime-print-part (&optional handle filename) 4547 "Print the MIME part under point." 4548 (interactive (list nil (ps-print-preprint current-prefix-arg))) 4549 (gnus-article-check-buffer) 4550 (let* ((handle (or handle (get-text-property (point) 'gnus-data))) 4551 (contents (and handle (mm-get-part handle))) 4552 (file (mm-make-temp-file (expand-file-name "mm." mm-tmp-directory))) 4553 (printer (mailcap-mime-info (mm-handle-media-type handle) "print"))) 4554 (when contents 4555 (if printer 4556 (unwind-protect 4557 (progn 4558 (mm-save-part-to-file handle file) 4559 (call-process shell-file-name nil 4560 (generate-new-buffer " *mm*") 4561 nil 4562 shell-command-switch 4563 (mm-mailcap-command 4564 printer file (mm-handle-type handle)))) 4565 (delete-file file)) 4566 (with-temp-buffer 4567 (insert contents) 4568 (gnus-print-buffer)) 4569 (ps-despool filename))))) 4570 4571(defun gnus-mime-inline-part (&optional handle arg) 4572 "Insert the MIME part under point into the current buffer." 4573 (interactive (list nil current-prefix-arg)) 4574 (gnus-article-check-buffer) 4575 (let* ((handle (or handle (get-text-property (point) 'gnus-data))) 4576 contents charset 4577 (b (point)) 4578 (inhibit-read-only t)) 4579 (when handle 4580 (if (and (not arg) (mm-handle-undisplayer handle)) 4581 (mm-remove-part handle) 4582 (setq contents (mm-get-part handle)) 4583 (cond 4584 ((not arg) 4585 (setq charset (or (mail-content-type-get 4586 (mm-handle-type handle) 'charset) 4587 gnus-newsgroup-charset))) 4588 ((numberp arg) 4589 (if (mm-handle-undisplayer handle) 4590 (mm-remove-part handle)) 4591 (setq charset 4592 (or (cdr (assq arg 4593 gnus-summary-show-article-charset-alist)) 4594 (mm-read-coding-system "Charset: ")))) 4595 (t 4596 (if (mm-handle-undisplayer handle) 4597 (mm-remove-part handle)))) 4598 (forward-line 2) 4599 (mm-insert-inline 4600 handle 4601 (if (and charset 4602 (setq charset (mm-charset-to-coding-system 4603 charset)) 4604 (not (eq charset 'ascii))) 4605 (mm-decode-coding-string contents charset) 4606 (mm-string-to-multibyte contents))) 4607 (goto-char b))))) 4608 4609(defun gnus-mime-strip-charset-parameters (handle) 4610 "Strip charset parameters from HANDLE." 4611 (if (stringp (car handle)) 4612 (mapc #'gnus-mime-strip-charset-parameters (cdr handle)) 4613 (let* ((type (mm-handle-type (if (equal (mm-handle-media-type handle) 4614 "message/external-body") 4615 (progn 4616 (unless (mm-handle-cache handle) 4617 (mm-extern-cache-contents handle)) 4618 (mm-handle-cache handle)) 4619 handle))) 4620 (charset (assq 'charset (cdr type)))) 4621 (when charset 4622 (delq charset type))))) 4623 4624(defun gnus-mime-view-part-as-charset (&optional handle arg) 4625 "Insert the MIME part under point into the current buffer using the 4626specified charset." 4627 (interactive (list nil current-prefix-arg)) 4628 (gnus-article-check-buffer) 4629 (let ((handle (or handle (get-text-property (point) 'gnus-data))) 4630 (fun (get-text-property (point) 'gnus-callback)) 4631 (gnus-newsgroup-ignored-charsets 'gnus-all) 4632 gnus-newsgroup-charset form preferred parts) 4633 (when handle 4634 (if (mm-handle-undisplayer handle) 4635 (mm-remove-part handle)) 4636 (when fun 4637 (setq gnus-newsgroup-charset 4638 (or (cdr (assq arg gnus-summary-show-article-charset-alist)) 4639 (mm-read-coding-system "Charset: "))) 4640 (gnus-mime-strip-charset-parameters handle) 4641 (when (and (consp (setq form (cdr-safe fun))) 4642 (setq form (ignore-errors 4643 (assq 'gnus-mime-display-alternative form))) 4644 (setq preferred (caddr form)) 4645 (progn 4646 (when (eq (car preferred) 'quote) 4647 (setq preferred (cadr preferred))) 4648 (not (equal preferred 4649 (get-text-property (point) 'gnus-data)))) 4650 (setq parts (get-text-property (point) 'gnus-part)) 4651 (setq parts (cdr (assq parts 4652 gnus-article-mime-handle-alist))) 4653 (equal (mm-handle-media-type parts) "multipart/alternative") 4654 (setq parts (reverse (cdr parts)))) 4655 (setcar (cddr form) 4656 (list 'quote (or (cadr (member preferred parts)) 4657 (car parts))))) 4658 (funcall fun handle))))) 4659 4660(defun gnus-mime-view-part-externally (&optional handle) 4661 "View the MIME part under point with an external viewer." 4662 (interactive) 4663 (gnus-article-check-buffer) 4664 (let* ((handle (or handle (get-text-property (point) 'gnus-data))) 4665 (mm-user-display-methods nil) 4666 (mm-inlined-types nil) 4667 (mail-parse-charset gnus-newsgroup-charset) 4668 (mail-parse-ignored-charsets 4669 (with-current-buffer gnus-summary-buffer 4670 gnus-newsgroup-ignored-charsets)) 4671 (type (mm-handle-media-type handle)) 4672 (method (mailcap-mime-info type)) 4673 (mm-enable-external t)) 4674 (if (not (stringp method)) 4675 (gnus-mime-view-part-as-type 4676 nil (lambda (type) (stringp (mailcap-mime-info type)))) 4677 (when handle 4678 (if (mm-handle-undisplayer handle) 4679 (mm-remove-part handle) 4680 (mm-display-part handle)))))) 4681 4682(defun gnus-mime-view-part-internally (&optional handle) 4683 "View the MIME part under point with an internal viewer. 4684If no internal viewer is available, use an external viewer." 4685 (interactive) 4686 (gnus-article-check-buffer) 4687 (let* ((handle (or handle (get-text-property (point) 'gnus-data))) 4688 (mm-inlined-types '(".*")) 4689 (mm-inline-large-images t) 4690 (mail-parse-charset gnus-newsgroup-charset) 4691 (mail-parse-ignored-charsets 4692 (with-current-buffer gnus-summary-buffer 4693 gnus-newsgroup-ignored-charsets)) 4694 (inhibit-read-only t)) 4695 (if (not (mm-inlinable-p handle)) 4696 (gnus-mime-view-part-as-type 4697 nil (lambda (type) (mm-inlinable-p handle type))) 4698 (when handle 4699 (if (mm-handle-undisplayer handle) 4700 (mm-remove-part handle) 4701 (mm-display-part handle)))))) 4702 4703(defun gnus-mime-action-on-part (&optional action) 4704 "Do something with the MIME attachment at \(point\)." 4705 (interactive 4706 (list (completing-read "Action: " gnus-mime-action-alist nil t))) 4707 (gnus-article-check-buffer) 4708 (let ((action-pair (assoc action gnus-mime-action-alist))) 4709 (if action-pair 4710 (funcall (cdr action-pair))))) 4711 4712(defun gnus-article-part-wrapper (n function) 4713 (let ((window (get-buffer-window gnus-article-buffer 'visible)) 4714 frame) 4715 (when window 4716 ;; It is necessary to select the article window so that 4717 ;; `gnus-article-goto-part' may really move the point. 4718 (setq frame (selected-frame)) 4719 (gnus-select-frame-set-input-focus (window-frame window)) 4720 (unwind-protect 4721 (save-window-excursion 4722 (select-window window) 4723 (when (> n (length gnus-article-mime-handle-alist)) 4724 (error "No such part")) 4725 (gnus-article-goto-part n) 4726 (let ((handle (cdr (assq n gnus-article-mime-handle-alist)))) 4727 (funcall function handle))) 4728 (gnus-select-frame-set-input-focus frame))))) 4729 4730(defun gnus-article-pipe-part (n) 4731 "Pipe MIME part N, which is the numerical prefix." 4732 (interactive "p") 4733 (gnus-article-part-wrapper n 'mm-pipe-part)) 4734 4735(defun gnus-article-save-part (n) 4736 "Save MIME part N, which is the numerical prefix." 4737 (interactive "p") 4738 (gnus-article-part-wrapper n 'mm-save-part)) 4739 4740(defun gnus-article-interactively-view-part (n) 4741 "View MIME part N interactively, which is the numerical prefix." 4742 (interactive "p") 4743 (gnus-article-part-wrapper n 'mm-interactively-view-part)) 4744 4745(defun gnus-article-copy-part (n) 4746 "Copy MIME part N, which is the numerical prefix." 4747 (interactive "p") 4748 (gnus-article-part-wrapper n 'gnus-mime-copy-part)) 4749 4750(defun gnus-article-view-part-as-charset (n) 4751 "View MIME part N using a specified charset. 4752N is the numerical prefix." 4753 (interactive "p") 4754 (gnus-article-part-wrapper n 'gnus-mime-view-part-as-charset)) 4755 4756(defun gnus-article-view-part-externally (n) 4757 "View MIME part N externally, which is the numerical prefix." 4758 (interactive "p") 4759 (gnus-article-part-wrapper n 'gnus-mime-view-part-externally)) 4760 4761(defun gnus-article-inline-part (n) 4762 "Inline MIME part N, which is the numerical prefix." 4763 (interactive "p") 4764 (gnus-article-part-wrapper n 'gnus-mime-inline-part)) 4765 4766(defun gnus-article-mime-match-handle-first (condition) 4767 (if condition 4768 (let ((alist gnus-article-mime-handle-alist) ihandle n) 4769 (while (setq ihandle (pop alist)) 4770 (if (and (cond 4771 ((functionp condition) 4772 (funcall condition (cdr ihandle))) 4773 ((eq condition 'undisplayed) 4774 (not (or (mm-handle-undisplayer (cdr ihandle)) 4775 (equal (mm-handle-media-type (cdr ihandle)) 4776 "multipart/alternative")))) 4777 ((eq condition 'undisplayed-alternative) 4778 (not (mm-handle-undisplayer (cdr ihandle)))) 4779 (t t)) 4780 (gnus-article-goto-part (car ihandle)) 4781 (or (not n) (< (car ihandle) n))) 4782 (setq n (car ihandle)))) 4783 (or n 1)) 4784 1)) 4785 4786(defun gnus-article-view-part (&optional n) 4787 "View MIME part N, which is the numerical prefix." 4788 (interactive "P") 4789 (save-current-buffer 4790 (set-buffer gnus-article-buffer) 4791 (or (numberp n) (setq n (gnus-article-mime-match-handle-first 4792 gnus-article-mime-match-handle-function))) 4793 (when (> n (length gnus-article-mime-handle-alist)) 4794 (error "No such part")) 4795 (let ((handle (cdr (assq n gnus-article-mime-handle-alist)))) 4796 (when (gnus-article-goto-part n) 4797 (if (equal (car handle) "multipart/alternative") 4798 (gnus-article-press-button) 4799 (when (eq (gnus-mm-display-part handle) 'internal) 4800 (gnus-set-window-start))))))) 4801 4802(defsubst gnus-article-mime-total-parts () 4803 (if (bufferp (car gnus-article-mime-handles)) 4804 1 ;; single part 4805 (1- (length gnus-article-mime-handles)))) 4806 4807(defun gnus-mm-display-part (handle) 4808 "Display HANDLE and fix MIME button." 4809 (let ((id (get-text-property (point) 'gnus-part)) 4810 (point (point)) 4811 (inhibit-read-only t)) 4812 (forward-line 1) 4813 (prog1 4814 (let ((window (selected-window)) 4815 (mail-parse-charset gnus-newsgroup-charset) 4816 (mail-parse-ignored-charsets 4817 (if (gnus-buffer-live-p gnus-summary-buffer) 4818 (save-excursion 4819 (set-buffer gnus-summary-buffer) 4820 gnus-newsgroup-ignored-charsets) 4821 nil))) 4822 (save-excursion 4823 (unwind-protect 4824 (let ((win (gnus-get-buffer-window (current-buffer) t)) 4825 (beg (point))) 4826 (when win 4827 (select-window win)) 4828 (goto-char point) 4829 (forward-line) 4830 (if (mm-handle-displayed-p handle) 4831 ;; This will remove the part. 4832 (mm-display-part handle) 4833 (save-restriction 4834 (narrow-to-region (point) 4835 (if (eobp) (point) (1+ (point)))) 4836 (mm-display-part handle) 4837 ;; We narrow to the part itself and 4838 ;; then call the treatment functions. 4839 (goto-char (point-min)) 4840 (forward-line 1) 4841 (narrow-to-region (point) (point-max)) 4842 (gnus-treat-article 4843 nil id 4844 (gnus-article-mime-total-parts) 4845 (mm-handle-media-type handle))))) 4846 (if (window-live-p window) 4847 (select-window window))))) 4848 (goto-char point) 4849 (gnus-delete-line) 4850 (gnus-insert-mime-button 4851 handle id (list (mm-handle-displayed-p handle))) 4852 (goto-char point)))) 4853 4854(defun gnus-article-goto-part (n) 4855 "Go to MIME part N." 4856 (gnus-goto-char (text-property-any (point-min) (point-max) 'gnus-part n))) 4857 4858(defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed) 4859 (let ((gnus-tmp-name 4860 (or (mail-content-type-get (mm-handle-type handle) 'name) 4861 (mail-content-type-get (mm-handle-disposition handle) 'filename) 4862 (mail-content-type-get (mm-handle-type handle) 'url) 4863 "")) 4864 (gnus-tmp-type (mm-handle-media-type handle)) 4865 (gnus-tmp-description 4866 (mail-decode-encoded-word-string (or (mm-handle-description handle) 4867 ""))) 4868 (gnus-tmp-dots 4869 (if (if displayed (car displayed) 4870 (mm-handle-displayed-p handle)) 4871 "" "...")) 4872 (gnus-tmp-length (with-current-buffer (mm-handle-buffer handle) 4873 (buffer-size))) 4874 gnus-tmp-type-long b e) 4875 (when (string-match ".*/" gnus-tmp-name) 4876 (setq gnus-tmp-name (replace-match "" t t gnus-tmp-name))) 4877 (setq gnus-tmp-type-long (concat gnus-tmp-type 4878 (and (not (equal gnus-tmp-name "")) 4879 (concat "; " gnus-tmp-name)))) 4880 (unless (equal gnus-tmp-description "") 4881 (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long))) 4882 (unless (bolp) 4883 (insert "\n")) 4884 (setq b (point)) 4885 (gnus-eval-format 4886 gnus-mime-button-line-format gnus-mime-button-line-format-alist 4887 `(,@(gnus-local-map-property gnus-mime-button-map) 4888 gnus-callback gnus-mm-display-part 4889 gnus-part ,gnus-tmp-id 4890 article-type annotation 4891 gnus-data ,handle)) 4892 (setq e (if (bolp) 4893 ;; Exclude a newline. 4894 (1- (point)) 4895 (point))) 4896 (widget-convert-button 4897 'link b e 4898 :mime-handle handle 4899 :action 'gnus-widget-press-button 4900 :button-keymap gnus-mime-button-map 4901 :help-echo 4902 (lambda (widget/window &optional overlay pos) 4903 ;; Needed to properly clear the message due to a bug in 4904 ;; wid-edit (XEmacs only). 4905 (if (boundp 'help-echo-owns-message) 4906 (setq help-echo-owns-message t)) 4907 (format 4908 "%S: %s the MIME part; %S: more options" 4909 (aref gnus-mouse-2 0) 4910 ;; XEmacs will get a single widget arg; Emacs 21 will get 4911 ;; window, overlay, position. 4912 (if (mm-handle-displayed-p 4913 (if overlay 4914 (with-current-buffer (gnus-overlay-buffer overlay) 4915 (widget-get (widget-at (gnus-overlay-start overlay)) 4916 :mime-handle)) 4917 (widget-get widget/window :mime-handle))) 4918 "hide" "show") 4919 (aref gnus-down-mouse-3 0)))))) 4920 4921(defun gnus-widget-press-button (elems el) 4922 (goto-char (widget-get elems :from)) 4923 (gnus-article-press-button)) 4924 4925(defvar gnus-displaying-mime nil) 4926 4927(defun gnus-display-mime (&optional ihandles) 4928 "Display the MIME parts." 4929 (save-excursion 4930 (save-selected-window 4931 (let ((window (get-buffer-window gnus-article-buffer)) 4932 (point (point))) 4933 (when window 4934 (select-window window) 4935 ;; We have to do this since selecting the window 4936 ;; may change the point. So we set the window point. 4937 (set-window-point window point))) 4938 (let ((handles ihandles) 4939 (inhibit-read-only t) 4940 handle) 4941 (cond (handles) 4942 ((setq handles (mm-dissect-buffer nil gnus-article-loose-mime)) 4943 (when gnus-article-emulate-mime 4944 (mm-uu-dissect-text-parts handles))) 4945 (gnus-article-emulate-mime 4946 (setq handles (mm-uu-dissect)))) 4947 (when (and (not ihandles) 4948 (not gnus-displaying-mime)) 4949 ;; Top-level call; we clean up. 4950 (when gnus-article-mime-handles 4951 (mm-destroy-parts gnus-article-mime-handles) 4952 (setq gnus-article-mime-handle-alist nil));; A trick. 4953 (setq gnus-article-mime-handles handles) 4954 ;; We allow users to glean info from the handles. 4955 (when gnus-article-mime-part-function 4956 (gnus-mime-part-function handles))) 4957 (if (and handles 4958 (or (not (stringp (car handles))) 4959 (cdr handles))) 4960 (progn 4961 (when (and (not ihandles) 4962 (not gnus-displaying-mime)) 4963 ;; Clean up for mime parts. 4964 (article-goto-body) 4965 (delete-region (point) (point-max))) 4966 (let ((gnus-displaying-mime t)) 4967 (gnus-mime-display-part handles))) 4968 (save-restriction 4969 (article-goto-body) 4970 (narrow-to-region (point) (point-max)) 4971 (gnus-treat-article nil 1 1) 4972 (widen))) 4973 (unless ihandles 4974 ;; Highlight the headers. 4975 (save-excursion 4976 (save-restriction 4977 (article-goto-body) 4978 (narrow-to-region (point-min) (point)) 4979 (gnus-article-save-original-date 4980 (gnus-treat-article 'head))))))) 4981 ;; Cope with broken MIME messages. 4982 (goto-char (point-max)) 4983 (unless (bolp) 4984 (insert "\n")))) 4985 4986(defcustom gnus-mime-display-multipart-as-mixed nil 4987 "Display \"multipart\" parts as \"multipart/mixed\". 4988 4989If t, it overrides nil values of 4990`gnus-mime-display-multipart-alternative-as-mixed' and 4991`gnus-mime-display-multipart-related-as-mixed'." 4992 :group 'gnus-article-mime 4993 :type 'boolean) 4994 4995(defcustom gnus-mime-display-multipart-alternative-as-mixed nil 4996 "Display \"multipart/alternative\" parts as \"multipart/mixed\"." 4997 :version "22.1" 4998 :group 'gnus-article-mime 4999 :type 'boolean) 5000 5001(defcustom gnus-mime-display-multipart-related-as-mixed nil 5002 "Display \"multipart/related\" parts as \"multipart/mixed\". 5003 5004If displaying \"text/html\" is discouraged \(see 5005`mm-discouraged-alternatives'\) images or other material inside a 5006\"multipart/related\" part might be overlooked when this variable is nil." 5007 :version "22.1" 5008 :group 'gnus-article-mime 5009 :type 'boolean) 5010 5011(defun gnus-mime-display-part (handle) 5012 (cond 5013 ;; Maybe a broken MIME message. 5014 ((null handle)) 5015 ;; Single part. 5016 ((not (stringp (car handle))) 5017 (gnus-mime-display-single handle)) 5018 ;; User-defined multipart 5019 ((cdr (assoc (car handle) gnus-mime-multipart-functions)) 5020 (funcall (cdr (assoc (car handle) gnus-mime-multipart-functions)) 5021 handle)) 5022 ;; multipart/alternative 5023 ((and (equal (car handle) "multipart/alternative") 5024 (not (or gnus-mime-display-multipart-as-mixed 5025 gnus-mime-display-multipart-alternative-as-mixed))) 5026 (let ((id (1+ (length gnus-article-mime-handle-alist)))) 5027 (push (cons id handle) gnus-article-mime-handle-alist) 5028 (gnus-mime-display-alternative (cdr handle) nil nil id))) 5029 ;; multipart/related 5030 ((and (equal (car handle) "multipart/related") 5031 (not (or gnus-mime-display-multipart-as-mixed 5032 gnus-mime-display-multipart-related-as-mixed))) 5033 ;;;!!!We should find the start part, but we just default 5034 ;;;!!!to the first part. 5035 ;;(gnus-mime-display-part (cadr handle)) 5036 ;;;!!! Most multipart/related is an HTML message plus images. 5037 ;;;!!! Unfortunately we are unable to let W3 display those 5038 ;;;!!! included images, so we just display it as a mixed multipart. 5039 ;;(gnus-mime-display-mixed (cdr handle)) 5040 ;;;!!! No, w3 can display everything just fine. 5041 (gnus-mime-display-part (cadr handle))) 5042 ((equal (car handle) "multipart/signed") 5043 (gnus-add-wash-type 'signed) 5044 (gnus-mime-display-security handle)) 5045 ((equal (car handle) "multipart/encrypted") 5046 (gnus-add-wash-type 'encrypted) 5047 (gnus-mime-display-security handle)) 5048 ;; Other multiparts are handled like multipart/mixed. 5049 (t 5050 (gnus-mime-display-mixed (cdr handle))))) 5051 5052(defun gnus-mime-part-function (handles) 5053 (if (stringp (car handles)) 5054 (mapcar 'gnus-mime-part-function (cdr handles)) 5055 (funcall gnus-article-mime-part-function handles))) 5056 5057(defun gnus-mime-display-mixed (handles) 5058 (mapcar 'gnus-mime-display-part handles)) 5059 5060(defun gnus-mime-display-single (handle) 5061 (let ((type (mm-handle-media-type handle)) 5062 (ignored gnus-ignored-mime-types) 5063 (not-attachment t) 5064 (move nil) 5065 display text) 5066 (catch 'ignored 5067 (progn 5068 (while ignored 5069 (when (string-match (pop ignored) type) 5070 (throw 'ignored nil))) 5071 (if (and (setq not-attachment 5072 (and (not (mm-inline-override-p handle)) 5073 (or (not (mm-handle-disposition handle)) 5074 (equal (car (mm-handle-disposition handle)) 5075 "inline") 5076 (mm-attachment-override-p handle)))) 5077 (mm-automatic-display-p handle) 5078 (or (and 5079 (mm-inlinable-p handle) 5080 (mm-inlined-p handle)) 5081 (mm-automatic-external-display-p type))) 5082 (setq display t) 5083 (when (equal (mm-handle-media-supertype handle) "text") 5084 (setq text t))) 5085 (let ((id (1+ (length gnus-article-mime-handle-alist))) 5086 beg) 5087 (push (cons id handle) gnus-article-mime-handle-alist) 5088 (when (and display 5089 (equal (mm-handle-media-supertype handle) "message")) 5090 (insert-char 5091 ?\n 5092 (cond ((not (bolp)) 2) 5093 ((or (bobp) (eq (char-before (1- (point))) ?\n)) 0) 5094 (t 1)))) 5095 (when (or (not display) 5096 (not (gnus-unbuttonized-mime-type-p type))) 5097 (gnus-insert-mime-button 5098 handle id (list (or display (and not-attachment text)))) 5099 (gnus-article-insert-newline) 5100 ;; Remember modify the number of forward lines. 5101 (setq move t)) 5102 (setq beg (point)) 5103 (cond 5104 (display 5105 (when move 5106 (forward-line -1) 5107 (setq beg (point))) 5108 (let ((mail-parse-charset gnus-newsgroup-charset) 5109 (mail-parse-ignored-charsets 5110 (save-excursion (condition-case () 5111 (set-buffer gnus-summary-buffer) 5112 (error)) 5113 gnus-newsgroup-ignored-charsets))) 5114 (mm-display-part handle t)) 5115 (goto-char (point-max))) 5116 ((and text not-attachment) 5117 (when move 5118 (forward-line -1) 5119 (setq beg (point))) 5120 (gnus-article-insert-newline) 5121 (mm-insert-inline 5122 handle 5123 (let ((charset (mail-content-type-get (mm-handle-type handle) 5124 'charset))) 5125 (cond ((not charset) 5126 (mm-string-as-multibyte (mm-get-part handle))) 5127 ((eq charset 'gnus-decoded) 5128 (with-current-buffer (mm-handle-buffer handle) 5129 (buffer-string))) 5130 (t 5131 (mm-decode-string (mm-get-part handle) charset))))) 5132 (goto-char (point-max)))) 5133 ;; Do highlighting. 5134 (save-excursion 5135 (save-restriction 5136 (narrow-to-region beg (point)) 5137 (gnus-treat-article 5138 nil id 5139 (gnus-article-mime-total-parts) 5140 (mm-handle-media-type handle))))))))) 5141 5142(defun gnus-unbuttonized-mime-type-p (type) 5143 "Say whether TYPE is to be unbuttonized." 5144 (unless gnus-inhibit-mime-unbuttonizing 5145 (when (catch 'found 5146 (let ((types gnus-unbuttonized-mime-types)) 5147 (while types 5148 (when (string-match (pop types) type) 5149 (throw 'found t))))) 5150 (not (catch 'found 5151 (let ((types gnus-buttonized-mime-types)) 5152 (while types 5153 (when (string-match (pop types) type) 5154 (throw 'found t))))))))) 5155 5156(defun gnus-article-insert-newline () 5157 "Insert a newline, but mark it as undeletable." 5158 (gnus-put-text-property 5159 (point) (progn (insert "\n") (point)) 'gnus-undeletable t)) 5160 5161(defun gnus-mime-display-alternative (handles &optional preferred ibegend id) 5162 (let* ((preferred (or preferred (mm-preferred-alternative handles))) 5163 (ihandles handles) 5164 (point (point)) 5165 handle (inhibit-read-only t) from props begend not-pref) 5166 (save-window-excursion 5167 (save-restriction 5168 (when ibegend 5169 (narrow-to-region (car ibegend) 5170 (or (cdr ibegend) 5171 (progn 5172 (goto-char (car ibegend)) 5173 (forward-line 2) 5174 (point)))) 5175 (delete-region (point-min) (point-max)) 5176 (mm-remove-parts handles)) 5177 (setq begend (list (point-marker))) 5178 ;; Do the toggle. 5179 (unless (setq not-pref (cadr (member preferred ihandles))) 5180 (setq not-pref (car ihandles))) 5181 (when (or ibegend 5182 (not preferred) 5183 (not (gnus-unbuttonized-mime-type-p 5184 "multipart/alternative"))) 5185 (gnus-add-text-properties 5186 (setq from (point)) 5187 (progn 5188 (insert (format "%d. " id)) 5189 (point)) 5190 `(gnus-callback 5191 (lambda (handles) 5192 (unless ,(not ibegend) 5193 (setq gnus-article-mime-handle-alist 5194 ',gnus-article-mime-handle-alist)) 5195 (gnus-mime-display-alternative 5196 ',ihandles ',not-pref ',begend ,id)) 5197 ,@(gnus-local-map-property gnus-mime-button-map) 5198 ,gnus-mouse-face-prop ,gnus-article-mouse-face 5199 face ,gnus-article-button-face 5200 gnus-part ,id 5201 article-type multipart)) 5202 (widget-convert-button 'link from (point) 5203 :action 'gnus-widget-press-button 5204 :button-keymap gnus-widget-button-keymap) 5205 ;; Do the handles 5206 (while (setq handle (pop handles)) 5207 (gnus-add-text-properties 5208 (setq from (point)) 5209 (progn 5210 (insert (format "(%c) %-18s" 5211 (if (equal handle preferred) ?* ? ) 5212 (mm-handle-media-type handle))) 5213 (point)) 5214 `(gnus-callback 5215 (lambda (handles) 5216 (unless ,(not ibegend) 5217 (setq gnus-article-mime-handle-alist 5218 ',gnus-article-mime-handle-alist)) 5219 (gnus-mime-display-alternative 5220 ',ihandles ',handle ',begend ,id)) 5221 ,@(gnus-local-map-property gnus-mime-button-map) 5222 ,gnus-mouse-face-prop ,gnus-article-mouse-face 5223 face ,gnus-article-button-face 5224 gnus-part ,id 5225 gnus-data ,handle)) 5226 (widget-convert-button 'link from (point) 5227 :action 'gnus-widget-press-button 5228 :button-keymap gnus-widget-button-keymap) 5229 (insert " ")) 5230 (insert "\n\n")) 5231 (when preferred 5232 (if (stringp (car preferred)) 5233 (gnus-display-mime preferred) 5234 (let ((mail-parse-charset gnus-newsgroup-charset) 5235 (mail-parse-ignored-charsets 5236 (save-excursion (set-buffer gnus-summary-buffer) 5237 gnus-newsgroup-ignored-charsets))) 5238 (mm-display-part preferred) 5239 ;; Do highlighting. 5240 (save-excursion 5241 (save-restriction 5242 (narrow-to-region (car begend) (point-max)) 5243 (gnus-treat-article 5244 nil (length gnus-article-mime-handle-alist) 5245 (gnus-article-mime-total-parts) 5246 (mm-handle-media-type handle)))))) 5247 (goto-char (point-max)) 5248 (setcdr begend (point-marker))))) 5249 (when ibegend 5250 (goto-char point)))) 5251 5252(defconst gnus-article-wash-status-strings 5253 (let ((alist '((cite "c" "Possible hidden citation text" 5254 " " "All citation text visible") 5255 (headers "h" "Hidden headers" 5256 " " "All headers visible.") 5257 (pgp "p" "Encrypted or signed message status hidden" 5258 " " "No hidden encryption nor digital signature status") 5259 (signature "s" "Signature has been hidden" 5260 " " "Signature is visible") 5261 (overstrike "o" "Overstrike (^H) characters applied" 5262 " " "No overstrike characters applied") 5263 (emphasis "e" "/*_Emphasis_*/ characters applied" 5264 " " "No /*_emphasis_*/ characters applied"))) 5265 result) 5266 (dolist (entry alist result) 5267 (let ((key (nth 0 entry)) 5268 (on (copy-sequence (nth 1 entry))) 5269 (on-help (nth 2 entry)) 5270 (off (copy-sequence (nth 3 entry))) 5271 (off-help (nth 4 entry))) 5272 (put-text-property 0 1 'help-echo on-help on) 5273 (put-text-property 0 1 'help-echo off-help off) 5274 (push (list key on off) result)))) 5275 "Alist of strings describing wash status in the mode line. 5276Each entry has the form (KEY ON OF), where the KEY is a symbol 5277representing the particular washing function, ON is the string to use 5278in the article mode line when the washing function is active, and OFF 5279is the string to use when it is inactive.") 5280 5281(defun gnus-article-wash-status-entry (key value) 5282 (let ((entry (assoc key gnus-article-wash-status-strings))) 5283 (if value (nth 1 entry) (nth 2 entry)))) 5284 5285(defun gnus-article-wash-status () 5286 "Return a string which display status of article washing." 5287 (save-excursion 5288 (set-buffer gnus-article-buffer) 5289 (let ((cite (memq 'cite gnus-article-wash-types)) 5290 (headers (memq 'headers gnus-article-wash-types)) 5291 (boring (memq 'boring-headers gnus-article-wash-types)) 5292 (pgp (memq 'pgp gnus-article-wash-types)) 5293 (pem (memq 'pem gnus-article-wash-types)) 5294 (signed (memq 'signed gnus-article-wash-types)) 5295 (encrypted (memq 'encrypted gnus-article-wash-types)) 5296 (signature (memq 'signature gnus-article-wash-types)) 5297 (overstrike (memq 'overstrike gnus-article-wash-types)) 5298 (emphasis (memq 'emphasis gnus-article-wash-types))) 5299 (concat 5300 (gnus-article-wash-status-entry 'cite cite) 5301 (gnus-article-wash-status-entry 'headers (or headers boring)) 5302 (gnus-article-wash-status-entry 'pgp (or pgp pem signed encrypted)) 5303 (gnus-article-wash-status-entry 'signature signature) 5304 (gnus-article-wash-status-entry 'overstrike overstrike) 5305 (gnus-article-wash-status-entry 'emphasis emphasis))))) 5306 5307(defun gnus-add-wash-type (type) 5308 "Add a washing of TYPE to the current status." 5309 (add-to-list 'gnus-article-wash-types type)) 5310 5311(defun gnus-delete-wash-type (type) 5312 "Add a washing of TYPE to the current status." 5313 (setq gnus-article-wash-types (delq type gnus-article-wash-types))) 5314 5315(defun gnus-add-image (category image) 5316 "Add IMAGE of CATEGORY to the list of displayed images." 5317 (let ((entry (assq category gnus-article-image-alist))) 5318 (unless entry 5319 (setq entry (list category)) 5320 (push entry gnus-article-image-alist)) 5321 (nconc entry (list image)))) 5322 5323(defun gnus-delete-images (category) 5324 "Delete all images in CATEGORY." 5325 (let ((entry (assq category gnus-article-image-alist))) 5326 (dolist (image (cdr entry)) 5327 (gnus-remove-image image category)) 5328 (setq gnus-article-image-alist (delq entry gnus-article-image-alist)) 5329 (gnus-delete-wash-type category))) 5330 5331(defalias 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers) 5332 5333(defun gnus-article-maybe-hide-headers () 5334 "Hide unwanted headers if `gnus-have-all-headers' is nil. 5335Provided for backwards compatibility." 5336 (when (and (or (not (gnus-buffer-live-p gnus-summary-buffer)) 5337 (not (save-excursion (set-buffer gnus-summary-buffer) 5338 gnus-have-all-headers))) 5339 (not gnus-inhibit-hiding)) 5340 (gnus-article-hide-headers))) 5341 5342;;; Article savers. 5343 5344(defun gnus-output-to-file (file-name) 5345 "Append the current article to a file named FILE-NAME. 5346If `gnus-article-save-coding-system' is non-nil, it is used to encode 5347text and used as the value of the coding cookie which is added to the 5348top of a file. Otherwise, this function saves a raw article without 5349the coding cookie." 5350 (let* ((artbuf (current-buffer)) 5351 (file-name-coding-system nnmail-pathname-coding-system) 5352 (coding gnus-article-save-coding-system) 5353 (coding-system-for-read (if coding 5354 nil ;; Rely on the coding cookie. 5355 mm-text-coding-system)) 5356 (coding-system-for-write (or coding 5357 mm-text-coding-system-for-write 5358 mm-text-coding-system)) 5359 (exists (file-exists-p file-name))) 5360 (with-temp-buffer 5361 (when exists 5362 (insert-file-contents file-name) 5363 (goto-char (point-min)) 5364 ;; Remove the existing coding cookie. 5365 (when (looking-at "X-Gnus-Coding-System: .+\n\n") 5366 (delete-region (match-beginning 0) (match-end 0)))) 5367 (goto-char (point-max)) 5368 (insert-buffer-substring artbuf) 5369 ;; Append newline at end of the buffer as separator, and then 5370 ;; save it to file. 5371 (goto-char (point-max)) 5372 (insert "\n") 5373 (when coding 5374 ;; If the coding system is not suitable to encode the text, 5375 ;; ask a user for a proper one. 5376 (when (fboundp 'select-safe-coding-system) 5377 (setq coding (coding-system-base 5378 (save-window-excursion 5379 (select-safe-coding-system (point-min) (point-max) 5380 coding)))) 5381 (setq coding-system-for-write 5382 (or (cdr (assq coding '((mule-utf-8 . utf-8)))) 5383 coding))) 5384 (goto-char (point-min)) 5385 ;; Add the coding cookie. 5386 (insert (format "X-Gnus-Coding-System: -*- coding: %s; -*-\n\n" 5387 coding-system-for-write))) 5388 (if exists 5389 (progn 5390 (write-region (point-min) (point-max) file-name nil 'no-message) 5391 (message "Appended to %s" file-name)) 5392 (write-region (point-min) (point-max) file-name)))) 5393 t) 5394 5395(defun gnus-narrow-to-page (&optional arg) 5396 "Narrow the article buffer to a page. 5397If given a numerical ARG, move forward ARG pages." 5398 (interactive "P") 5399 (setq arg (if arg (prefix-numeric-value arg) 0)) 5400 (save-excursion 5401 (set-buffer gnus-article-buffer) 5402 (goto-char (point-min)) 5403 (widen) 5404 ;; Remove any old next/prev buttons. 5405 (when (gnus-visual-p 'page-marker) 5406 (let ((inhibit-read-only t)) 5407 (gnus-remove-text-with-property 'gnus-prev) 5408 (gnus-remove-text-with-property 'gnus-next))) 5409 (if 5410 (cond ((< arg 0) 5411 (re-search-backward page-delimiter nil 'move (1+ (abs arg)))) 5412 ((> arg 0) 5413 (re-search-forward page-delimiter nil 'move arg))) 5414 (goto-char (match-end 0)) 5415 (save-excursion 5416 (goto-char (point-min)) 5417 (setq gnus-page-broken 5418 (and (re-search-forward page-delimiter nil t) t)))) 5419 (when gnus-page-broken 5420 (narrow-to-region 5421 (point) 5422 (if (re-search-forward page-delimiter nil 'move) 5423 (match-beginning 0) 5424 (point))) 5425 (when (and (gnus-visual-p 'page-marker) 5426 (> (point-min) (save-restriction (widen) (point-min)))) 5427 (save-excursion 5428 (goto-char (point-min)) 5429 (gnus-insert-prev-page-button))) 5430 (when (and (gnus-visual-p 'page-marker) 5431 (< (point-max) (save-restriction (widen) (point-max)))) 5432 (save-excursion 5433 (goto-char (point-max)) 5434 (gnus-insert-next-page-button)))))) 5435 5436;; Article mode commands 5437 5438(defun gnus-article-goto-next-page () 5439 "Show the next page of the article." 5440 (interactive) 5441 (when (gnus-article-next-page) 5442 (goto-char (point-min)) 5443 (gnus-article-read-summary-keys nil (gnus-character-to-event ?n)))) 5444 5445 5446(defun gnus-article-goto-prev-page () 5447 "Show the previous page of the article." 5448 (interactive) 5449 (if (bobp) 5450 (gnus-article-read-summary-keys nil (gnus-character-to-event ?p)) 5451 (gnus-article-prev-page nil))) 5452 5453;; This is cleaner but currently breaks `gnus-pick-mode': 5454;; 5455;; (defun gnus-article-goto-next-page () 5456;; "Show the next page of the article." 5457;; (interactive) 5458;; (gnus-eval-in-buffer-window gnus-summary-buffer 5459;; (gnus-summary-next-page))) 5460;; 5461;; (defun gnus-article-goto-prev-page () 5462;; "Show the next page of the article." 5463;; (interactive) 5464;; (gnus-eval-in-buffer-window gnus-summary-buffer 5465;; (gnus-summary-prev-page))) 5466 5467(defun gnus-article-next-page (&optional lines) 5468 "Show the next page of the current article. 5469If end of article, return non-nil. Otherwise return nil. 5470Argument LINES specifies lines to be scrolled up." 5471 (interactive "p") 5472 (move-to-window-line -1) 5473 (if (save-excursion 5474 (end-of-line) 5475 (and (pos-visible-in-window-p) ;Not continuation line. 5476 (>= (1+ (point)) (point-max)))) ;Allow for trailing newline. 5477 ;; Nothing in this page. 5478 (if (or (not gnus-page-broken) 5479 (save-excursion 5480 (save-restriction 5481 (widen) 5482 (forward-line) 5483 (eobp)))) ;Real end-of-buffer? 5484 (progn 5485 (when gnus-article-over-scroll 5486 (gnus-article-next-page-1 lines)) 5487 t) ;Nothing more. 5488 (gnus-narrow-to-page 1) ;Go to next page. 5489 nil) 5490 ;; More in this page. 5491 (gnus-article-next-page-1 lines) 5492 nil)) 5493 5494(defmacro gnus-article-beginning-of-window () 5495 "Move point to the beginning of the window. 5496In Emacs, the point is placed at the line number which `scroll-margin' 5497specifies." 5498 (if (featurep 'xemacs) 5499 '(move-to-window-line 0) 5500 '(move-to-window-line 5501 (min (max 0 scroll-margin) 5502 (max 1 (- (window-height) 5503 (if mode-line-format 1 0) 5504 (if (and (boundp 'header-line-format) 5505 (symbol-value 'header-line-format)) 5506 1 0))))))) 5507 5508(defun gnus-article-next-page-1 (lines) 5509 (when (and (not (featurep 'xemacs)) 5510 (numberp lines) 5511 (> lines 0) 5512 (numberp (symbol-value 'scroll-margin)) 5513 (> (symbol-value 'scroll-margin) 0)) 5514 ;; Protect against the bug that Emacs 21.x hangs up when scrolling up for 5515 ;; too many number of lines if `scroll-margin' is set as two or greater. 5516 (setq lines (min lines 5517 (max 0 (- (count-lines (window-start) (point-max)) 5518 (symbol-value 'scroll-margin)))))) 5519 (condition-case () 5520 (let ((scroll-in-place nil)) 5521 (scroll-up lines)) 5522 (end-of-buffer 5523 ;; Long lines may cause an end-of-buffer error. 5524 (goto-char (point-max)))) 5525 (gnus-article-beginning-of-window)) 5526 5527(defun gnus-article-prev-page (&optional lines) 5528 "Show previous page of current article. 5529Argument LINES specifies lines to be scrolled down." 5530 (interactive "p") 5531 (move-to-window-line 0) 5532 (if (and gnus-page-broken 5533 (bobp) 5534 (not (save-restriction (widen) (bobp)))) ;Real beginning-of-buffer? 5535 (progn 5536 (gnus-narrow-to-page -1) ;Go to previous page. 5537 (goto-char (point-max)) 5538 (recenter -1)) 5539 (prog1 5540 (condition-case () 5541 (let ((scroll-in-place nil)) 5542 (scroll-down lines)) 5543 (beginning-of-buffer 5544 (goto-char (point-min)))) 5545 (gnus-article-beginning-of-window)))) 5546 5547(defun gnus-article-only-boring-p () 5548 "Decide whether there is only boring text remaining in the article. 5549Something \"interesting\" is a word of at least two letters that does 5550not have a face in `gnus-article-boring-faces'." 5551 (when (and gnus-article-skip-boring 5552 (boundp 'gnus-article-boring-faces) 5553 (symbol-value 'gnus-article-boring-faces)) 5554 (save-excursion 5555 (let ((inhibit-point-motion-hooks t)) 5556 (catch 'only-boring 5557 (while (re-search-forward "\\b\\w\\w" nil t) 5558 (forward-char -1) 5559 (when (not (gnus-intersection 5560 (gnus-faces-at (point)) 5561 (symbol-value 'gnus-article-boring-faces))) 5562 (throw 'only-boring nil))) 5563 (throw 'only-boring t)))))) 5564 5565(defun gnus-article-refer-article () 5566 "Read article specified by message-id around point." 5567 (interactive) 5568 (save-excursion 5569 (re-search-backward "[ \t]\\|^" (gnus-point-at-bol) t) 5570 (re-search-forward "<?news:<?\\|<" (gnus-point-at-eol) t) 5571 (if (re-search-forward "[^@ ]+@[^ \t>]+" (gnus-point-at-eol) t) 5572 (let ((msg-id (concat "<" (match-string 0) ">"))) 5573 (set-buffer gnus-summary-buffer) 5574 (gnus-summary-refer-article msg-id)) 5575 (error "No references around point")))) 5576 5577(defun gnus-article-show-summary () 5578 "Reconfigure windows to show summary buffer." 5579 (interactive) 5580 (if (not (gnus-buffer-live-p gnus-summary-buffer)) 5581 (error "There is no summary buffer for this article buffer") 5582 (gnus-article-set-globals) 5583 (gnus-configure-windows 'article) 5584 (gnus-summary-goto-subject gnus-current-article) 5585 (gnus-summary-position-point))) 5586 5587(defun gnus-article-describe-briefly () 5588 "Describe article mode commands briefly." 5589 (interactive) 5590 (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"))) 5591 5592(defun gnus-article-summary-command () 5593 "Execute the last keystroke in the summary buffer." 5594 (interactive) 5595 (let ((obuf (current-buffer)) 5596 (owin (current-window-configuration)) 5597 func) 5598 (switch-to-buffer gnus-article-current-summary 'norecord) 5599 (setq func (lookup-key (current-local-map) (this-command-keys))) 5600 (call-interactively func) 5601 (set-buffer obuf) 5602 (set-window-configuration owin) 5603 (set-window-point (get-buffer-window (current-buffer)) (point)))) 5604 5605(defun gnus-article-summary-command-nosave () 5606 "Execute the last keystroke in the summary buffer." 5607 (interactive) 5608 (let (func) 5609 (pop-to-buffer gnus-article-current-summary 'norecord) 5610 (setq func (lookup-key (current-local-map) (this-command-keys))) 5611 (call-interactively func))) 5612 5613(defun gnus-article-check-buffer () 5614 "Beep if not in an article buffer." 5615 (unless (equal major-mode 'gnus-article-mode) 5616 (error "Command invoked outside of a Gnus article buffer"))) 5617 5618(defun gnus-article-read-summary-keys (&optional arg key not-restore-window) 5619 "Read a summary buffer key sequence and execute it from the article buffer." 5620 (interactive "P") 5621 (gnus-article-check-buffer) 5622 (let ((nosaves 5623 '("q" "Q" "c" "r" "\C-c\C-f" "m" "a" "f" 5624 "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP" 5625 "=" "^" "\M-^" "|")) 5626 (nosave-but-article 5627 '("A\r")) 5628 (nosave-in-article 5629 '("\C-d")) 5630 (up-to-top 5631 '("n" "Gn" "p" "Gp")) 5632 keys new-sum-point) 5633 (save-excursion 5634 (set-buffer gnus-article-current-summary) 5635 (let (gnus-pick-mode) 5636 (push (or key last-command-event) unread-command-events) 5637 (setq keys (if (featurep 'xemacs) 5638 (events-to-keys (read-key-sequence nil)) 5639 (read-key-sequence nil))))) 5640 5641 (message "") 5642 5643 (if (or (member keys nosaves) 5644 (member keys nosave-but-article) 5645 (member keys nosave-in-article)) 5646 (let (func) 5647 (save-window-excursion 5648 (pop-to-buffer gnus-article-current-summary 'norecord) 5649 ;; We disable the pick minor mode commands. 5650 (let (gnus-pick-mode) 5651 (setq func (lookup-key (current-local-map) keys)))) 5652 (if (or (not func) 5653 (numberp func)) 5654 (ding) 5655 (unless (member keys nosave-in-article) 5656 (set-buffer gnus-article-current-summary)) 5657 (call-interactively func) 5658 (setq new-sum-point (point))) 5659 (when (member keys nosave-but-article) 5660 (pop-to-buffer gnus-article-buffer 'norecord))) 5661 ;; These commands should restore window configuration. 5662 (let ((obuf (current-buffer)) 5663 (owin (current-window-configuration)) 5664 (opoint (point)) 5665 win func in-buffer selected new-sum-start new-sum-hscroll) 5666 (cond (not-restore-window 5667 (pop-to-buffer gnus-article-current-summary 'norecord)) 5668 ((setq win (get-buffer-window gnus-article-current-summary)) 5669 (select-window win)) 5670 (t 5671 (switch-to-buffer gnus-article-current-summary 'norecord))) 5672 (setq in-buffer (current-buffer)) 5673 ;; We disable the pick minor mode commands. 5674 (if (and (setq func (let (gnus-pick-mode) 5675 (lookup-key (current-local-map) keys))) 5676 (functionp func)) 5677 (progn 5678 (call-interactively func) 5679 (when (eq win (selected-window)) 5680 (setq new-sum-point (point) 5681 new-sum-start (window-start win) 5682 new-sum-hscroll (window-hscroll win))) 5683 (when (eq in-buffer (current-buffer)) 5684 (setq selected (gnus-summary-select-article)) 5685 (set-buffer obuf) 5686 (unless not-restore-window 5687 (set-window-configuration owin)) 5688 (when (eq selected 'old) 5689 (article-goto-body) 5690 (set-window-start (get-buffer-window (current-buffer)) 5691 1) 5692 (set-window-point (get-buffer-window (current-buffer)) 5693 (point))) 5694 (when (and (not not-restore-window) 5695 new-sum-point) 5696 (set-window-point win new-sum-point) 5697 (set-window-start win new-sum-start) 5698 (set-window-hscroll win new-sum-hscroll)))) 5699 (set-window-configuration owin) 5700 (ding)))))) 5701 5702(defun gnus-article-describe-key (key) 5703 "Display documentation of the function invoked by KEY. KEY is a string." 5704 (interactive "kDescribe key: ") 5705 (gnus-article-check-buffer) 5706 (if (eq (key-binding key) 'gnus-article-read-summary-keys) 5707 (save-excursion 5708 (set-buffer gnus-article-current-summary) 5709 (let (gnus-pick-mode) 5710 (if (featurep 'xemacs) 5711 (progn 5712 (push (elt key 0) unread-command-events) 5713 (setq key (events-to-keys 5714 (read-key-sequence "Describe key: ")))) 5715 (setq unread-command-events 5716 (mapcar 5717 (lambda (x) (if (>= x 128) (list 'meta (- x 128)) x)) 5718 (string-to-list key))) 5719 (setq key (read-key-sequence "Describe key: ")))) 5720 (describe-key key)) 5721 (describe-key key))) 5722 5723(defun gnus-article-describe-key-briefly (key &optional insert) 5724 "Display documentation of the function invoked by KEY. KEY is a string." 5725 (interactive "kDescribe key: \nP") 5726 (gnus-article-check-buffer) 5727 (if (eq (key-binding key) 'gnus-article-read-summary-keys) 5728 (save-excursion 5729 (set-buffer gnus-article-current-summary) 5730 (let (gnus-pick-mode) 5731 (if (featurep 'xemacs) 5732 (progn 5733 (push (elt key 0) unread-command-events) 5734 (setq key (events-to-keys 5735 (read-key-sequence "Describe key: ")))) 5736 (setq unread-command-events 5737 (mapcar 5738 (lambda (x) (if (>= x 128) (list 'meta (- x 128)) x)) 5739 (string-to-list key))) 5740 (setq key (read-key-sequence "Describe key: ")))) 5741 (describe-key-briefly key insert)) 5742 (describe-key-briefly key insert))) 5743 5744(defun gnus-article-reply-with-original (&optional wide) 5745 "Start composing a reply mail to the current message. 5746The text in the region will be yanked. If the region isn't active, 5747the entire article will be yanked." 5748 (interactive "P") 5749 (let ((article (cdr gnus-article-current)) 5750 contents) 5751 (if (not (gnus-mark-active-p)) 5752 (with-current-buffer gnus-summary-buffer 5753 (gnus-summary-reply (list (list article)) wide)) 5754 (setq contents (buffer-substring (point) (mark t))) 5755 ;; Deactivate active regions. 5756 (when (and (boundp 'transient-mark-mode) 5757 transient-mark-mode) 5758 (setq mark-active nil)) 5759 (with-current-buffer gnus-summary-buffer 5760 (gnus-summary-reply 5761 (list (list article contents)) wide))))) 5762 5763(defun gnus-article-followup-with-original () 5764 "Compose a followup to the current article. 5765The text in the region will be yanked. If the region isn't active, 5766the entire article will be yanked." 5767 (interactive) 5768 (let ((article (cdr gnus-article-current)) 5769 contents) 5770 (if (not (gnus-mark-active-p)) 5771 (with-current-buffer gnus-summary-buffer 5772 (gnus-summary-followup (list (list article)))) 5773 (setq contents (buffer-substring (point) (mark t))) 5774 ;; Deactivate active regions. 5775 (when (and (boundp 'transient-mark-mode) 5776 transient-mark-mode) 5777 (setq mark-active nil)) 5778 (with-current-buffer gnus-summary-buffer 5779 (gnus-summary-followup 5780 (list (list article contents))))))) 5781 5782(defun gnus-article-hide (&optional arg force) 5783 "Hide all the gruft in the current article. 5784This means that signatures, cited text and (some) headers will be 5785hidden. 5786If given a prefix, show the hidden text instead." 5787 (interactive (append (gnus-article-hidden-arg) (list 'force))) 5788 (gnus-article-hide-headers arg) 5789 (gnus-article-hide-list-identifiers arg) 5790 (gnus-article-hide-citation-maybe arg force) 5791 (gnus-article-hide-signature arg)) 5792 5793(defun gnus-article-maybe-highlight () 5794 "Do some article highlighting if article highlighting is requested." 5795 (when (gnus-visual-p 'article-highlight 'highlight) 5796 (gnus-article-highlight-some))) 5797 5798(defun gnus-check-group-server () 5799 ;; Make sure the connection to the server is alive. 5800 (unless (gnus-server-opened 5801 (gnus-find-method-for-group gnus-newsgroup-name)) 5802 (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name)) 5803 (gnus-request-group gnus-newsgroup-name t))) 5804 5805(eval-when-compile 5806 (autoload 'nneething-get-file-name "nneething")) 5807 5808(defun gnus-request-article-this-buffer (article group) 5809 "Get an article and insert it into this buffer." 5810 (let (do-update-line sparse-header) 5811 (prog1 5812 (save-excursion 5813 (erase-buffer) 5814 (gnus-kill-all-overlays) 5815 (setq group (or group gnus-newsgroup-name)) 5816 5817 ;; Using `gnus-request-article' directly will insert the article into 5818 ;; `nntp-server-buffer' - so we'll save some time by not having to 5819 ;; copy it from the server buffer into the article buffer. 5820 5821 ;; We only request an article by message-id when we do not have the 5822 ;; headers for it, so we'll have to get those. 5823 (when (stringp article) 5824 (gnus-read-header article)) 5825 5826 ;; If the article number is negative, that means that this article 5827 ;; doesn't belong in this newsgroup (possibly), so we find its 5828 ;; message-id and request it by id instead of number. 5829 (when (and (numberp article) 5830 gnus-summary-buffer 5831 (get-buffer gnus-summary-buffer) 5832 (gnus-buffer-exists-p gnus-summary-buffer)) 5833 (save-excursion 5834 (set-buffer gnus-summary-buffer) 5835 (let ((header (gnus-summary-article-header article))) 5836 (when (< article 0) 5837 (cond 5838 ((memq article gnus-newsgroup-sparse) 5839 ;; This is a sparse gap article. 5840 (setq do-update-line article) 5841 (setq article (mail-header-id header)) 5842 (setq sparse-header (gnus-read-header article)) 5843 (setq gnus-newsgroup-sparse 5844 (delq article gnus-newsgroup-sparse))) 5845 ((vectorp header) 5846 ;; It's a real article. 5847 (setq article (mail-header-id header))) 5848 (t 5849 ;; It is an extracted pseudo-article. 5850 (setq article 'pseudo) 5851 (gnus-request-pseudo-article header)))) 5852 5853 (let ((method (gnus-find-method-for-group 5854 gnus-newsgroup-name))) 5855 (when (and (eq (car method) 'nneething) 5856 (vectorp header)) 5857 (let ((dir (nneething-get-file-name 5858 (mail-header-id header)))) 5859 (when (and (stringp dir) 5860 (file-directory-p dir)) 5861 (setq article 'nneething) 5862 (gnus-group-enter-directory dir)))))))) 5863 5864 (cond 5865 ;; Refuse to select canceled articles. 5866 ((and (numberp article) 5867 gnus-summary-buffer 5868 (get-buffer gnus-summary-buffer) 5869 (gnus-buffer-exists-p gnus-summary-buffer) 5870 (eq (cdr (save-excursion 5871 (set-buffer gnus-summary-buffer) 5872 (assq article gnus-newsgroup-reads))) 5873 gnus-canceled-mark)) 5874 nil) 5875 ;; We first check `gnus-original-article-buffer'. 5876 ((and (get-buffer gnus-original-article-buffer) 5877 (numberp article) 5878 (save-excursion 5879 (set-buffer gnus-original-article-buffer) 5880 (and (equal (car gnus-original-article) group) 5881 (eq (cdr gnus-original-article) article)))) 5882 (insert-buffer-substring gnus-original-article-buffer) 5883 'article) 5884 ;; Check the backlog. 5885 ((and gnus-keep-backlog 5886 (gnus-backlog-request-article group article (current-buffer))) 5887 'article) 5888 ;; Check asynchronous pre-fetch. 5889 ((gnus-async-request-fetched-article group article (current-buffer)) 5890 (gnus-async-prefetch-next group article gnus-summary-buffer) 5891 (when (and (numberp article) gnus-keep-backlog) 5892 (gnus-backlog-enter-article group article (current-buffer))) 5893 'article) 5894 ;; Check the cache. 5895 ((and gnus-use-cache 5896 (numberp article) 5897 (gnus-cache-request-article article group)) 5898 'article) 5899 ;; Check the agent cache. 5900 ((gnus-agent-request-article article group) 5901 'article) 5902 ;; Get the article and put into the article buffer. 5903 ((or (stringp article) 5904 (numberp article)) 5905 (let ((gnus-override-method gnus-override-method) 5906 (methods (and (stringp article) 5907 gnus-refer-article-method)) 5908 (backend (car (gnus-find-method-for-group 5909 gnus-newsgroup-name))) 5910 result 5911 (inhibit-read-only t)) 5912 (if (or (not (listp methods)) 5913 (and (symbolp (car methods)) 5914 (assq (car methods) nnoo-definition-alist))) 5915 (setq methods (list methods))) 5916 (when (and (null gnus-override-method) 5917 methods) 5918 (setq gnus-override-method (pop methods))) 5919 (while (not result) 5920 (when (eq gnus-override-method 'current) 5921 (setq gnus-override-method 5922 (with-current-buffer gnus-summary-buffer 5923 gnus-current-select-method))) 5924 (erase-buffer) 5925 (gnus-kill-all-overlays) 5926 (let ((gnus-newsgroup-name group)) 5927 (gnus-check-group-server)) 5928 (cond 5929 ((gnus-request-article article group (current-buffer)) 5930 (when (numberp article) 5931 (gnus-async-prefetch-next group article 5932 gnus-summary-buffer) 5933 (when gnus-keep-backlog 5934 (gnus-backlog-enter-article 5935 group article (current-buffer)))) 5936 (setq result 'article)) 5937 (methods 5938 (setq gnus-override-method (pop methods))) 5939 ((not (string-match "^400 " 5940 (nnheader-get-report backend))) 5941 ;; If we get 400 server disconnect, reconnect and 5942 ;; retry; otherwise, assume the article has expired. 5943 (setq result 'done)))) 5944 (and (eq result 'article) 'article))) 5945 ;; It was a pseudo. 5946 (t article))) 5947 5948 ;; Associate this article with the current summary buffer. 5949 (setq gnus-article-current-summary gnus-summary-buffer) 5950 5951 ;; Take the article from the original article buffer 5952 ;; and place it in the buffer it's supposed to be in. 5953 (when (and (get-buffer gnus-article-buffer) 5954 (equal (buffer-name (current-buffer)) 5955 (buffer-name (get-buffer gnus-article-buffer)))) 5956 (save-excursion 5957 (if (get-buffer gnus-original-article-buffer) 5958 (set-buffer gnus-original-article-buffer) 5959 (set-buffer (gnus-get-buffer-create gnus-original-article-buffer)) 5960 (buffer-disable-undo) 5961 (setq major-mode 'gnus-original-article-mode) 5962 (setq buffer-read-only t)) 5963 (let ((inhibit-read-only t)) 5964 (erase-buffer) 5965 (insert-buffer-substring gnus-article-buffer)) 5966 (setq gnus-original-article (cons group article))) 5967 5968 ;; Decode charsets. 5969 (run-hooks 'gnus-article-decode-hook) 5970 ;; Mark article as decoded or not. 5971 (setq gnus-article-decoded-p gnus-article-decode-hook)) 5972 5973 ;; Update sparse articles. 5974 (when (and do-update-line 5975 (or (numberp article) 5976 (stringp article))) 5977 (let ((buf (current-buffer))) 5978 (set-buffer gnus-summary-buffer) 5979 (gnus-summary-update-article do-update-line sparse-header) 5980 (gnus-summary-goto-subject do-update-line nil t) 5981 (set-window-point (gnus-get-buffer-window (current-buffer) t) 5982 (point)) 5983 (set-buffer buf)))))) 5984 5985;;; 5986;;; Article editing 5987;;; 5988 5989(defcustom gnus-article-edit-mode-hook nil 5990 "Hook run in article edit mode buffers." 5991 :group 'gnus-article-various 5992 :type 'hook) 5993 5994(defvar gnus-article-edit-done-function nil) 5995 5996(defvar gnus-article-edit-mode-map nil) 5997(defvar gnus-article-edit-mode nil) 5998 5999;; Should we be using derived.el for this? 6000(unless gnus-article-edit-mode-map 6001 (setq gnus-article-edit-mode-map (make-keymap)) 6002 (set-keymap-parent gnus-article-edit-mode-map text-mode-map) 6003 6004 (gnus-define-keys gnus-article-edit-mode-map 6005 "\C-c?" describe-mode 6006 "\C-c\C-c" gnus-article-edit-done 6007 "\C-c\C-k" gnus-article-edit-exit 6008 "\C-c\C-f\C-t" message-goto-to 6009 "\C-c\C-f\C-o" message-goto-from 6010 "\C-c\C-f\C-b" message-goto-bcc 6011 ;;"\C-c\C-f\C-w" message-goto-fcc 6012 "\C-c\C-f\C-c" message-goto-cc 6013 "\C-c\C-f\C-s" message-goto-subject 6014 "\C-c\C-f\C-r" message-goto-reply-to 6015 "\C-c\C-f\C-n" message-goto-newsgroups 6016 "\C-c\C-f\C-d" message-goto-distribution 6017 "\C-c\C-f\C-f" message-goto-followup-to 6018 "\C-c\C-f\C-m" message-goto-mail-followup-to 6019 "\C-c\C-f\C-k" message-goto-keywords 6020 "\C-c\C-f\C-u" message-goto-summary 6021 "\C-c\C-f\C-i" message-insert-or-toggle-importance 6022 "\C-c\C-f\C-a" message-generate-unsubscribed-mail-followup-to 6023 "\C-c\C-b" message-goto-body 6024 "\C-c\C-i" message-goto-signature 6025 6026 "\C-c\C-t" message-insert-to 6027 "\C-c\C-n" message-insert-newsgroups 6028 "\C-c\C-o" message-sort-headers 6029 "\C-c\C-e" message-elide-region 6030 "\C-c\C-v" message-delete-not-region 6031 "\C-c\C-z" message-kill-to-signature 6032 "\M-\r" message-newline-and-reformat 6033 "\C-c\C-a" mml-attach-file 6034 "\C-a" message-beginning-of-line 6035 "\t" message-tab 6036 "\M-;" comment-region) 6037 6038 (gnus-define-keys (gnus-article-edit-wash-map 6039 "\C-c\C-w" gnus-article-edit-mode-map) 6040 "f" gnus-article-edit-full-stops)) 6041 6042(easy-menu-define 6043 gnus-article-edit-mode-field-menu gnus-article-edit-mode-map "" 6044 '("Field" 6045 ["Fetch To" message-insert-to t] 6046 ["Fetch Newsgroups" message-insert-newsgroups t] 6047 "----" 6048 ["To" message-goto-to t] 6049 ["From" message-goto-from t] 6050 ["Subject" message-goto-subject t] 6051 ["Cc" message-goto-cc t] 6052 ["Reply-To" message-goto-reply-to t] 6053 ["Summary" message-goto-summary t] 6054 ["Keywords" message-goto-keywords t] 6055 ["Newsgroups" message-goto-newsgroups t] 6056 ["Followup-To" message-goto-followup-to t] 6057 ["Mail-Followup-To" message-goto-mail-followup-to t] 6058 ["Distribution" message-goto-distribution t] 6059 ["Body" message-goto-body t] 6060 ["Signature" message-goto-signature t])) 6061 6062(define-derived-mode gnus-article-edit-mode message-mode "Article Edit" 6063 "Major mode for editing articles. 6064This is an extended text-mode. 6065 6066\\{gnus-article-edit-mode-map}" 6067 (make-local-variable 'gnus-article-edit-done-function) 6068 (make-local-variable 'gnus-prev-winconf) 6069 (set (make-local-variable 'font-lock-defaults) 6070 '(message-font-lock-keywords t)) 6071 (set (make-local-variable 'mail-header-separator) "") 6072 (set (make-local-variable 'gnus-article-edit-mode) t) 6073 (easy-menu-add message-mode-field-menu message-mode-map) 6074 (mml-mode) 6075 (setq buffer-read-only nil) 6076 (buffer-enable-undo) 6077 (widen)) 6078 6079(defun gnus-article-edit (&optional force) 6080 "Edit the current article. 6081This will have permanent effect only in mail groups. 6082If FORCE is non-nil, allow editing of articles even in read-only 6083groups." 6084 (interactive "P") 6085 (when (and (not force) 6086 (gnus-group-read-only-p)) 6087 (error "The current newsgroup does not support article editing")) 6088 (gnus-article-date-original) 6089 (gnus-article-edit-article 6090 'ignore 6091 `(lambda (no-highlight) 6092 'ignore 6093 (gnus-summary-edit-article-done 6094 ,(or (mail-header-references gnus-current-headers) "") 6095 ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight)))) 6096 6097(defun gnus-article-edit-article (start-func exit-func) 6098 "Start editing the contents of the current article buffer." 6099 (let ((winconf (current-window-configuration))) 6100 (set-buffer gnus-article-buffer) 6101 (let ((message-auto-save-directory 6102 ;; Don't associate the article buffer with a draft file. 6103 nil)) 6104 (gnus-article-edit-mode)) 6105 (funcall start-func) 6106 (set-buffer-modified-p nil) 6107 (gnus-configure-windows 'edit-article) 6108 (setq gnus-article-edit-done-function exit-func) 6109 (setq gnus-prev-winconf winconf) 6110 (gnus-message 6 "C-c C-c to end edits"))) 6111 6112(defun gnus-article-edit-done (&optional arg) 6113 "Update the article edits and exit." 6114 (interactive "P") 6115 (let ((func gnus-article-edit-done-function) 6116 (buf (current-buffer)) 6117 (start (window-start)) 6118 (p (point)) 6119 (winconf gnus-prev-winconf)) 6120 (widen) ;; Widen it in case that users narrowed the buffer. 6121 (funcall func arg) 6122 (set-buffer buf) 6123 ;; The cache and backlog have to be flushed somewhat. 6124 (when gnus-keep-backlog 6125 (gnus-backlog-remove-article 6126 (car gnus-article-current) (cdr gnus-article-current))) 6127 ;; Flush original article as well. 6128 (save-excursion 6129 (when (get-buffer gnus-original-article-buffer) 6130 (set-buffer gnus-original-article-buffer) 6131 (setq gnus-original-article nil))) 6132 (when gnus-use-cache 6133 (gnus-cache-update-article 6134 (car gnus-article-current) (cdr gnus-article-current))) 6135 ;; We remove all text props from the article buffer. 6136 (kill-all-local-variables) 6137 (gnus-set-text-properties (point-min) (point-max) nil) 6138 (gnus-article-mode) 6139 (set-window-configuration winconf) 6140 (set-buffer buf) 6141 (set-window-start (get-buffer-window buf) start) 6142 (set-window-point (get-buffer-window buf) (point))) 6143 (gnus-summary-show-article)) 6144 6145(defun gnus-article-edit-exit () 6146 "Exit the article editing without updating." 6147 (interactive) 6148 (when (or (not (buffer-modified-p)) 6149 (yes-or-no-p "Article modified; kill anyway? ")) 6150 (let ((curbuf (current-buffer)) 6151 (p (point)) 6152 (window-start (window-start))) 6153 (erase-buffer) 6154 (if (gnus-buffer-live-p gnus-original-article-buffer) 6155 (insert-buffer-substring gnus-original-article-buffer)) 6156 (let ((winconf gnus-prev-winconf)) 6157 (kill-all-local-variables) 6158 (gnus-article-mode) 6159 (set-window-configuration winconf) 6160 ;; Tippy-toe some to make sure that point remains where it was. 6161 (save-current-buffer 6162 (set-buffer curbuf) 6163 (set-window-start (get-buffer-window (current-buffer)) window-start) 6164 (goto-char p)))) 6165 (gnus-summary-show-article))) 6166 6167(defun gnus-article-edit-full-stops () 6168 "Interactively repair spacing at end of sentences." 6169 (interactive) 6170 (save-excursion 6171 (goto-char (point-min)) 6172 (search-forward-regexp "^$" nil t) 6173 (let ((case-fold-search nil)) 6174 (query-replace-regexp "\\([.!?][])}]* \\)\\([[({A-Z]\\)" "\\1 \\2")))) 6175 6176;;; 6177;;; Article highlights 6178;;; 6179 6180;; Written by Per Abrahamsen <abraham@iesd.auc.dk>. 6181 6182;;; Internal Variables: 6183 6184(defcustom gnus-button-url-regexp 6185 (if (string-match "[[:digit:]]" "1") ;; support POSIX? 6186 "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)\\(//[-a-z0-9_.]+:[0-9]*\\)?[-a-z0-9_=!?#$@~%&*+\\/:;.,[:word:]]+[-a-z0-9_=#$@~%&*+\\/[:word:]]\\)" 6187 "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)\\(//[-a-z0-9_.]+:[0-9]*\\)?\\([-a-z0-9_=!?#$@~%&*+\\/:;.,]\\|\\w\\)+\\([-a-z0-9_=#$@~%&*+\\/]\\|\\w\\)\\)") 6188 "Regular expression that matches URLs." 6189 :group 'gnus-article-buttons 6190 :type 'regexp) 6191 6192(defcustom gnus-button-valid-fqdn-regexp 6193 message-valid-fqdn-regexp 6194 "Regular expression that matches a valid FQDN." 6195 :version "22.1" 6196 :group 'gnus-article-buttons 6197 :type 'regexp) 6198 6199;; Regexp suggested by Felix Wiemann in <87oeuomcz9.fsf@news2.ososo.de> 6200(defcustom gnus-button-valid-localpart-regexp 6201 "[a-z0-9$%(*-=?[_][^<>\")!;:,{}\n\t @]*" 6202 "Regular expression that matches a localpart of mail addresses or MIDs." 6203 :version "22.1" 6204 :group 'gnus-article-buttons 6205 :type 'regexp) 6206 6207(defcustom gnus-button-man-handler 'manual-entry 6208 "Function to use for displaying man pages. 6209The function must take at least one argument with a string naming the 6210man page." 6211 :version "22.1" 6212 :type '(choice (function-item :tag "Man" manual-entry) 6213 (function-item :tag "Woman" woman) 6214 (function :tag "Other")) 6215 :group 'gnus-article-buttons) 6216 6217(defcustom gnus-ctan-url "http://tug.ctan.org/tex-archive/" 6218 "Top directory of a CTAN \(Comprehensive TeX Archive Network\) archive. 6219If the default site is too slow, try to find a CTAN mirror, see 6220<URL:http://tug.ctan.org/tex-archive/CTAN.sites?action=/index.html>. See also 6221the variable `gnus-button-handle-ctan'." 6222 :version "22.1" 6223 :group 'gnus-article-buttons 6224 :link '(custom-manual "(gnus)Group Parameters") 6225 :type '(choice (const "http://www.tex.ac.uk/tex-archive/") 6226 (const "http://tug.ctan.org/tex-archive/") 6227 (const "http://www.dante.de/CTAN/") 6228 (string :tag "Other"))) 6229 6230(defcustom gnus-button-ctan-handler 'browse-url 6231 "Function to use for displaying CTAN links. 6232The function must take one argument, the string naming the URL." 6233 :version "22.1" 6234 :type '(choice (function-item :tag "Browse Url" browse-url) 6235 (function :tag "Other")) 6236 :group 'gnus-article-buttons) 6237 6238(defcustom gnus-button-handle-ctan-bogus-regexp "^/?tex-archive/\\|^/" 6239 "Bogus strings removed from CTAN URLs." 6240 :version "22.1" 6241 :group 'gnus-article-buttons 6242 :type '(choice (const "^/?tex-archive/\\|/") 6243 (regexp :tag "Other"))) 6244 6245(defcustom gnus-button-ctan-directory-regexp 6246 (regexp-opt 6247 (list "archive-tools" "biblio" "bibliography" "digests" "documentation" 6248 "dviware" "fonts" "graphics" "help" "indexing" "info" "language" 6249 "languages" "macros" "nonfree" "obsolete" "support" "systems" 6250 "tds" "tools" "usergrps" "web") t) 6251 "Regular expression for ctan directories. 6252It should match all directories in the top level of `gnus-ctan-url'." 6253 :version "22.1" 6254 :group 'gnus-article-buttons 6255 :type 'regexp) 6256 6257(defcustom gnus-button-mid-or-mail-regexp 6258 (concat "\\b\\(<?" gnus-button-valid-localpart-regexp "@" 6259 gnus-button-valid-fqdn-regexp 6260 ">?\\)\\b") 6261 "Regular expression that matches a message ID or a mail address." 6262 :version "22.1" 6263 :group 'gnus-article-buttons 6264 :type 'regexp) 6265 6266(defcustom gnus-button-prefer-mid-or-mail 'gnus-button-mid-or-mail-heuristic 6267 "What to do when the button on a string as \"foo123@bar.invalid\" is pushed. 6268Strings like this can be either a message ID or a mail address. If it is one 6269of the symbols `mid' or `mail', Gnus will always assume that the string is a 6270message ID or a mail address, respectively. If this variable is set to the 6271symbol `ask', always query the user what do do. If it is a function, this 6272function will be called with the string as its only argument. The function 6273must return `mid', `mail', `invalid' or `ask'." 6274 :version "22.1" 6275 :group 'gnus-article-buttons 6276 :type '(choice (function-item :tag "Heuristic function" 6277 gnus-button-mid-or-mail-heuristic) 6278 (const ask) 6279 (const mid) 6280 (const mail))) 6281 6282(defcustom gnus-button-mid-or-mail-heuristic-alist 6283 '((-10.0 . ".+\\$.+@") 6284 (-10.0 . "#") 6285 (-10.0 . "\\*") 6286 (-5.0 . "\\+[^+]*\\+.*@") ;; # two plus signs 6287 (-5.0 . "@[Nn][Ee][Ww][Ss]") ;; /\@news/i 6288 (-5.0 . "@.*[Dd][Ii][Aa][Ll][Uu][Pp]") ;; /\@.*dialup/i; 6289 (-1.0 . "^[^a-z]+@") 6290 ;; 6291 (-5.0 . "\\.[0-9][0-9]+.*@") ;; "\.[0-9]{2,}.*\@" 6292 (-5.0 . "[a-z].*[A-Z].*[a-z].*[A-Z].*@") ;; "([a-z].*[A-Z].*){2,}\@" 6293 (-3.0 . "[A-Z][A-Z][a-z][a-z].*@") 6294 (-5.0 . "\\...?.?@") ;; (-5.0 . "\..{1,3}\@") 6295 ;; 6296 (-2.0 . "^[0-9]") 6297 (-1.0 . "^[0-9][0-9]") 6298 ;; 6299 ;; -3.0 /^[0-9][0-9a-fA-F]{2,2}/; 6300 (-3.0 . "^[0-9][0-9a-fA-F][0-9a-fA-F][^0-9a-fA-F]") 6301 ;; -5.0 /^[0-9][0-9a-fA-F]{3,3}/; 6302 (-5.0 . "^[0-9][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][^0-9a-fA-F]") 6303 ;; 6304 (-3.0 . "[0-9][0-9][0-9][0-9][0-9][^0-9].*@") ;; "[0-9]{5,}.*\@" 6305 (-3.0 . "[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][^0-9].*@") 6306 ;; "[0-9]{8,}.*\@" 6307 (-3.0 6308 . "[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9].*@") 6309 ;; "[0-9]{12,}.*\@" 6310 ;; compensation for TDMA dated mail addresses: 6311 (25.0 . "-dated-[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]+.*@") 6312 ;; 6313 (-20.0 . "\\.fsf@") ;; Gnus 6314 (-20.0 . "^slrn") 6315 (-20.0 . "^Pine") 6316 (-20.0 . "_-_") ;; Subject change in thread 6317 ;; 6318 (-20.0 . "\\.ln@") ;; leafnode 6319 (-30.0 . "@ID-[0-9]+\\.[a-zA-Z]+\\.dfncis\\.de") 6320 (-30.0 . "@4[Aa][Xx]\\.com") ;; Forte Agent 6321 ;; 6322 ;; (5.0 . "") ;; $local_part_len <= 7 6323 (10.0 . "^[^0-9]+@") 6324 (3.0 . "^[^0-9]+[0-9][0-9]?[0-9]?@") 6325 ;; ^[^0-9]+[0-9]{1,3}\@ digits only at end of local part 6326 (3.0 . "\@stud") 6327 ;; 6328 (2.0 . "[a-z][a-z][._-][A-Z][a-z].*@") 6329 ;; 6330 (0.5 . "^[A-Z][a-z]") 6331 (0.5 . "^[A-Z][a-z][a-z]") 6332 (1.5 . "^[A-Z][a-z][A-Z][a-z][^a-z]") ;; ^[A-Z][a-z]{3,3} 6333 (2.0 . "^[A-Z][a-z][A-Z][a-z][a-z][^a-z]")) ;; ^[A-Z][a-z]{4,4} 6334 "An alist of \(RATE . REGEXP\) pairs for `gnus-button-mid-or-mail-heuristic'. 6335 6336A negative RATE indicates a message IDs, whereas a positive indicates a mail 6337address. The REGEXP is processed with `case-fold-search' set to nil." 6338 :version "22.1" 6339 :group 'gnus-article-buttons 6340 :type '(repeat (cons (number :tag "Rate") 6341 (regexp :tag "Regexp")))) 6342 6343(defun gnus-button-mid-or-mail-heuristic (mid-or-mail) 6344 "Guess whether MID-OR-MAIL is a message ID or a mail address. 6345Returns `mid' if MID-OR-MAIL is a message IDs, `mail' if it's a mail 6346address, `ask' if unsure and `invalid' if the string is invalid." 6347 (let ((case-fold-search nil) 6348 (list gnus-button-mid-or-mail-heuristic-alist) 6349 (result 0) rate regexp lpartlen elem) 6350 (setq lpartlen 6351 (length (gnus-replace-in-string mid-or-mail "^\\(.*\\)@.*$" "\\1"))) 6352 (gnus-message 8 "`%s', length of local part=`%s'." mid-or-mail lpartlen) 6353 ;; Certain special cases... 6354 (when (string-match 6355 (concat 6356 "^0[0-9]+-[0-9][0-9][0-9][0-9]@t-online\\.de$\\|" 6357 "^[0-9]+\\.[0-9]+@compuserve\\|" 6358 "@public\\.gmane\\.org") 6359 mid-or-mail) 6360 (gnus-message 8 "`%s' is a known mail address." mid-or-mail) 6361 (setq result 'mail)) 6362 (when (string-match "@.*@\\| " mid-or-mail) 6363 (gnus-message 8 "`%s' is invalid." mid-or-mail) 6364 (setq result 'invalid)) 6365 ;; Nothing more to do, if result is not a number here... 6366 (when (numberp result) 6367 (while list 6368 (setq elem (car list) 6369 rate (car elem) 6370 regexp (cdr elem) 6371 list (cdr list)) 6372 (when (string-match regexp mid-or-mail) 6373 (setq result (+ result rate)) 6374 (gnus-message 6375 9 "`%s' matched `%s', rate `%s', result `%s'." 6376 mid-or-mail regexp rate result))) 6377 (when (<= lpartlen 7) 6378 (setq result (+ result 5.0)) 6379 (gnus-message 9 "`%s' matched (<= lpartlen 7), result `%s'." 6380 mid-or-mail result)) 6381 (when (>= lpartlen 12) 6382 (gnus-message 9 "`%s' matched (>= lpartlen 12)" mid-or-mail) 6383 (cond 6384 ((string-match "[0-9][^0-9]+[0-9].*@" mid-or-mail) 6385 ;; Long local part should contain realname if e-mail address, 6386 ;; too many digits: message-id. 6387 ;; $score -= 5.0 + 0.1 * $local_part_len; 6388 (setq rate (* -1.0 (+ 5.0 (* 0.1 lpartlen)))) 6389 (setq result (+ result rate)) 6390 (gnus-message 6391 9 "Many digits in `%s', rate `%s', result `%s'." 6392 mid-or-mail rate result)) 6393 ((string-match "[^aeiouy][^aeiouy][^aeiouy][^aeiouy]+.*\@" 6394 mid-or-mail) 6395 ;; Too few vowels [^aeiouy]{4,}.*\@ 6396 (setq result (+ result -5.0)) 6397 (gnus-message 6398 9 "Few vowels in `%s', rate `%s', result `%s'." 6399 mid-or-mail -5.0 result)) 6400 (t 6401 (setq result (+ result 5.0)) 6402 (gnus-message 6403 9 "`%s', rate `%s', result `%s'." mid-or-mail 5.0 result))))) 6404 (gnus-message 8 "`%s': Final rate is `%s'." mid-or-mail result) 6405 ;; Maybe we should make this a customizable alist: (condition . 'result) 6406 (cond 6407 ((symbolp result) result) 6408 ;; Now convert number into proper results: 6409 ((< result -10.0) 'mid) 6410 ((> result 10.0) 'mail) 6411 (t 'ask)))) 6412 6413(defun gnus-button-handle-mid-or-mail (mid-or-mail) 6414 (let* ((pref gnus-button-prefer-mid-or-mail) guessed 6415 (url-mid (concat "news" ":" mid-or-mail)) 6416 (url-mailto (concat "mailto" ":" mid-or-mail))) 6417 (gnus-message 9 "mid-or-mail=%s" mid-or-mail) 6418 (when (fboundp pref) 6419 (setq guessed 6420 ;; get rid of surrounding angles... 6421 (funcall pref 6422 (gnus-replace-in-string mid-or-mail "^<\\|>$" ""))) 6423 (if (or (eq 'mid guessed) (eq 'mail guessed)) 6424 (setq pref guessed) 6425 (setq pref 'ask))) 6426 (if (eq pref 'ask) 6427 (save-window-excursion 6428 (if (y-or-n-p (concat "Is <" mid-or-mail "> a mail address? ")) 6429 (setq pref 'mail) 6430 (setq pref 'mid)))) 6431 (cond ((eq pref 'mid) 6432 (gnus-message 8 "calling `gnus-button-handle-news' %s" url-mid) 6433 (gnus-button-handle-news url-mid)) 6434 ((eq pref 'mail) 6435 (gnus-message 8 "calling `gnus-url-mailto' %s" url-mailto) 6436 (gnus-url-mailto url-mailto)) 6437 (t (gnus-message 3 "Invalid string."))))) 6438 6439(defun gnus-button-handle-custom (url) 6440 "Follow a Custom URL." 6441 (customize-apropos (gnus-url-unhex-string url))) 6442 6443(defvar gnus-button-handle-describe-prefix "^\\(C-h\\|<?[Ff]1>?\\)") 6444 6445;; FIXME: Maybe we should merge some of the functions that do quite similar 6446;; stuff? 6447 6448(defun gnus-button-handle-describe-function (url) 6449 "Call `describe-function' when pushing the corresponding URL button." 6450 (describe-function 6451 (intern 6452 (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))) 6453 6454(defun gnus-button-handle-describe-variable (url) 6455 "Call `describe-variable' when pushing the corresponding URL button." 6456 (describe-variable 6457 (intern 6458 (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))) 6459 6460(defun gnus-button-handle-symbol (url) 6461"Display help on variable or function. 6462Calls `describe-variable' or `describe-function'." 6463 (let ((sym (intern url))) 6464 (cond 6465 ((fboundp sym) (describe-function sym)) 6466 ((boundp sym) (describe-variable sym)) 6467 (t (gnus-message 3 "`%s' is not a known function of variable." url))))) 6468 6469(defun gnus-button-handle-describe-key (url) 6470 "Call `describe-key' when pushing the corresponding URL button." 6471 (let* ((key-string 6472 (gnus-replace-in-string url gnus-button-handle-describe-prefix "")) 6473 (keys (ignore-errors (eval `(kbd ,key-string))))) 6474 (if keys 6475 (describe-key keys) 6476 (gnus-message 3 "Invalid key sequence in button: %s" key-string)))) 6477 6478(defun gnus-button-handle-apropos (url) 6479 "Call `apropos' when pushing the corresponding URL button." 6480 (apropos (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))) 6481 6482(defun gnus-button-handle-apropos-command (url) 6483 "Call `apropos' when pushing the corresponding URL button." 6484 (apropos-command 6485 (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))) 6486 6487(defun gnus-button-handle-apropos-variable (url) 6488 "Call `apropos' when pushing the corresponding URL button." 6489 (funcall 6490 (if (fboundp 'apropos-variable) 'apropos-variable 'apropos) 6491 (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))) 6492 6493(defun gnus-button-handle-apropos-documentation (url) 6494 "Call `apropos' when pushing the corresponding URL button." 6495 (funcall 6496 (if (fboundp 'apropos-documentation) 'apropos-documentation 'apropos) 6497 (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))) 6498 6499(defun gnus-button-handle-library (url) 6500 "Call `locate-library' when pushing the corresponding URL button." 6501 (gnus-message 9 "url=`%s'" url) 6502 (let* ((lib (locate-library url)) 6503 (file (gnus-replace-in-string (or lib "") "\.elc" ".el"))) 6504 (if (not lib) 6505 (gnus-message 1 "Cannot locale library `%s'." url) 6506 (find-file-read-only file)))) 6507 6508(defun gnus-button-handle-ctan (url) 6509 "Call `browse-url' when pushing a CTAN URL button." 6510 (funcall 6511 gnus-button-ctan-handler 6512 (concat 6513 gnus-ctan-url 6514 (gnus-replace-in-string url gnus-button-handle-ctan-bogus-regexp "")))) 6515 6516(defcustom gnus-button-tex-level 5 6517 "*Integer that says how many TeX-related buttons Gnus will show. 6518The higher the number, the more buttons will appear and the more false 6519positives are possible. Note that you can set this variable local to 6520specific groups. Setting it higher in TeX groups is probably a good idea. 6521See Info node `(gnus)Group Parameters' and the variable `gnus-parameters' on 6522how to set variables in specific groups." 6523 :version "22.1" 6524 :group 'gnus-article-buttons 6525 :link '(custom-manual "(gnus)Group Parameters") 6526 :type 'integer) 6527 6528(defcustom gnus-button-man-level 5 6529 "*Integer that says how many man-related buttons Gnus will show. 6530The higher the number, the more buttons will appear and the more false 6531positives are possible. Note that you can set this variable local to 6532specific groups. Setting it higher in Unix groups is probably a good idea. 6533See Info node `(gnus)Group Parameters' and the variable `gnus-parameters' on 6534how to set variables in specific groups." 6535 :version "22.1" 6536 :group 'gnus-article-buttons 6537 :link '(custom-manual "(gnus)Group Parameters") 6538 :type 'integer) 6539 6540(defcustom gnus-button-emacs-level 5 6541 "*Integer that says how many emacs-related buttons Gnus will show. 6542The higher the number, the more buttons will appear and the more false 6543positives are possible. Note that you can set this variable local to 6544specific groups. Setting it higher in Emacs or Gnus related groups is 6545probably a good idea. See Info node `(gnus)Group Parameters' and the variable 6546`gnus-parameters' on how to set variables in specific groups." 6547 :version "22.1" 6548 :group 'gnus-article-buttons 6549 :link '(custom-manual "(gnus)Group Parameters") 6550 :type 'integer) 6551 6552(defcustom gnus-button-message-level 5 6553 "*Integer that says how many buttons for news or mail messages will appear. 6554The higher the number, the more buttons will appear and the more false 6555positives are possible." 6556 ;; mail addresses, MIDs, URLs for news, ... 6557 :version "22.1" 6558 :group 'gnus-article-buttons 6559 :type 'integer) 6560 6561(defcustom gnus-button-browse-level 5 6562 "*Integer that says how many buttons for browsing will appear. 6563The higher the number, the more buttons will appear and the more false 6564positives are possible." 6565 ;; stuff handled by `browse-url' or `gnus-button-embedded-url' 6566 :version "22.1" 6567 :group 'gnus-article-buttons 6568 :type 'integer) 6569 6570(defcustom gnus-button-alist 6571 '(("<\\(url:[>\n\t ]*?\\)?\\(nntp\\|news\\):[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>" 6572 0 (>= gnus-button-message-level 0) gnus-button-handle-news 3) 6573 ((concat "\\b\\(nntp\\|news\\):\\(" 6574 gnus-button-valid-localpart-regexp "@[a-z0-9.-]+[a-z]\\)") 6575 0 t gnus-button-handle-news 2) 6576 ("\\(\\b<\\(url:[>\n\t ]*\\)?\\(nntp\\|news\\):[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)" 6577 1 (>= gnus-button-message-level 0) gnus-button-fetch-group 5) 6578 ("\\b\\(nntp\\|news\\):\\(//\\)?\\([^'\">\n\t ]+\\)" 6579 0 (>= gnus-button-message-level 0) gnus-button-fetch-group 3) 6580 ;; RFC 2392 (Don't allow `/' in domain part --> CID) 6581 ("\\bmid:\\(//\\)?\\([^'\">\n\t ]+@[^'\">\n\t /]+\\)" 6582 0 (>= gnus-button-message-level 0) gnus-button-message-id 2) 6583 ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 6584 2 (>= gnus-button-message-level 0) gnus-button-message-id 3) 6585 ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>" 6586 0 (>= gnus-button-message-level 0) gnus-url-mailto 2) 6587 ;; RFC 2368 (The mailto URL scheme) 6588 ("\\bmailto:\\([-a-z.@_+0-9%=?&/]+\\)" 6589 0 (>= gnus-button-message-level 0) gnus-url-mailto 1) 6590 ("\\bmailto:\\([^ \n\t]+\\)" 6591 0 (>= gnus-button-message-level 0) gnus-url-mailto 1) 6592 ;; CTAN 6593 ((concat "\\bCTAN:[ \t\n]?[^>)!;:,'\n\t ]*\\(" 6594 gnus-button-ctan-directory-regexp 6595 "[^][>)!;:,'\n\t ]+\\)") 6596 0 (>= gnus-button-tex-level 1) gnus-button-handle-ctan 1) 6597 ((concat "\\btex-archive/\\(" 6598 gnus-button-ctan-directory-regexp 6599 "/[-_.a-z0-9/]+[-_./a-z0-9]+[/a-z0-9]\\)") 6600 1 (>= gnus-button-tex-level 6) gnus-button-handle-ctan 1) 6601 ((concat 6602 "\\b\\(" 6603 gnus-button-ctan-directory-regexp 6604 "/[-_.a-z0-9]+/[-_./a-z0-9]+[/a-z0-9]\\)") 6605 1 (>= gnus-button-tex-level 8) gnus-button-handle-ctan 1) 6606 ;; This is info (home-grown style) <info://foo/bar+baz> 6607 ("\\binfo://\\([^'\">\n\t ]+\\)" 6608 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url 1) 6609 ;; Info GNOME style <info:foo#bar_baz> 6610 ("\\binfo:\\([^('\n\t\r \"><][^'\n\t\r \"><]*\\)" 6611 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url-gnome 1) 6612 ;; Info KDE style <info:(foo)bar baz> 6613 ("<\\(info:\\(([^)]+)[^>\n\r]*\\)\\)>" 6614 1 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url-kde 2) 6615 ("\\((Info-goto-node\\|(info\\)[ \t\n]*\\(\"[^\"]*\"\\))" 0 6616 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url 2) 6617 ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+i[ \t\n]+d?[ \t\n]?m[ \t\n]+\\([^ ]+ ?[^ ]+\\)[ \t\n]+RET" 6618 ;; Info links like `C-h i d m CC Mode RET' 6619 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-keystrokes 2) 6620 ;; This is custom 6621 ("\\bcustom:\\(//\\)?\\([^'\">\n\t ]+\\)" 6622 0 (>= gnus-button-emacs-level 5) gnus-button-handle-custom 2) 6623 ("M-x[ \t\n]customize-[^ ]+[ \t\n]RET[ \t\n]\\([^ ]+\\)[ \t\n]RET" 0 6624 (>= gnus-button-emacs-level 1) gnus-button-handle-custom 1) 6625 ;; Emacs help commands 6626 ("M-x[ \t\n]+apropos[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET" 6627 ;; regexp doesn't match arguments containing ` '. 6628 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos 1) 6629 ("M-x[ \t\n]+apropos-command[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET" 6630 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-command 1) 6631 ("M-x[ \t\n]+apropos-variable[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET" 6632 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-variable 1) 6633 ("M-x[ \t\n]+apropos-documentation[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET" 6634 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-documentation 1) 6635 ;; The following entries may lead to many false positives so don't enable 6636 ;; them by default (use a high button level). 6637 ("/\\([a-z][-a-z0-9]+\\.el\\)\\>[^.?]" 6638 ;; Exclude [.?] for URLs in gmane.emacs.cvs 6639 1 (>= gnus-button-emacs-level 8) gnus-button-handle-library 1) 6640 ("`\\([a-z][-a-z0-9]+\\.el\\)'" 6641 1 (>= gnus-button-emacs-level 8) gnus-button-handle-library 1) 6642 ("`\\([a-z][a-z0-9]+-[a-z]+-[-a-z]+\\|\\(gnus\\|message\\)-[-a-z]+\\)'" 6643 0 (>= gnus-button-emacs-level 8) gnus-button-handle-symbol 1) 6644 ("`\\([a-z][a-z0-9]+-[a-z]+\\)'" 6645 0 (>= gnus-button-emacs-level 9) gnus-button-handle-symbol 1) 6646 ("(setq[ \t\n]+\\([a-z][a-z0-9]+-[-a-z0-9]+\\)[ \t\n]+.+)" 6647 1 (>= gnus-button-emacs-level 7) gnus-button-handle-describe-variable 1) 6648 ("\\bM-x[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET" 6649 1 (>= gnus-button-emacs-level 7) gnus-button-handle-describe-function 1) 6650 ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+f[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET" 6651 0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-function 2) 6652 ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+v[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET" 6653 0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-variable 2) 6654 ("`\\(\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+k[ \t\n]+\\([^']+\\)\\)'" 6655 ;; Unlike the other regexps we really have to require quoting 6656 ;; here to determine where it ends. 6657 1 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-key 3) 6658 ;; This is how URLs _should_ be embedded in text (RFC 1738, RFC 2396)... 6659 ("<URL: *\\([^<>]*\\)>" 6660 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1) 6661 ;; RFC 2396 (2.4.3., delims) ... 6662 ("\"URL: *\\([^\"]*\\)\"" 6663 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1) 6664 ;; RFC 2396 (2.4.3., delims) ... 6665 ("\"URL: *\\([^\"]*\\)\"" 6666 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1) 6667 ;; Raw URLs. 6668 (gnus-button-url-regexp 6669 0 (>= gnus-button-browse-level 0) browse-url 0) 6670 ;; man pages 6671 ("\\b\\([a-z][a-z]+([1-9])\\)\\W" 6672 0 (and (>= gnus-button-man-level 1) (< gnus-button-man-level 3)) 6673 gnus-button-handle-man 1) 6674 ;; more man pages: resolv.conf(5), iso_8859-1(7), xterm(1x) 6675 ("\\b\\([a-z][-_.a-z0-9]+([1-9])\\)\\W" 6676 0 (and (>= gnus-button-man-level 3) (< gnus-button-man-level 5)) 6677 gnus-button-handle-man 1) 6678 ;; even more: Apache::PerlRun(3pm), PDL::IO::FastRaw(3pm), 6679 ;; SoWWWAnchor(3iv), XSelectInput(3X11), X(1), X(7) 6680 ("\\b\\(\\(?:[a-z][-+_.:a-z0-9]+([1-9][X1a-z]*)\\)\\|\\b\\(?:X([1-9])\\)\\)\\W" 6681 0 (>= gnus-button-man-level 5) gnus-button-handle-man 1) 6682 ;; MID or mail: To avoid too many false positives we don't try to catch 6683 ;; all kind of allowed MIDs or mail addresses. Domain part must contain 6684 ;; at least one dot. TLD must contain two or three chars or be a know TLD 6685 ;; (info|name|...). Put this entry near the _end_ of `gnus-button-alist' 6686 ;; so that non-ambiguous entries (see above) match first. 6687 (gnus-button-mid-or-mail-regexp 6688 0 (>= gnus-button-message-level 5) gnus-button-handle-mid-or-mail 1)) 6689 "*Alist of regexps matching buttons in article bodies. 6690 6691Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where 6692REGEXP: is the string (case insensitive) matching text around the button (can 6693also be Lisp expression evaluating to a string), 6694BUTTON: is the number of the regexp grouping actually matching the button, 6695FORM: is a Lisp expression which must eval to true for the button to 6696be added, 6697CALLBACK: is the function to call when the user push this button, and each 6698PAR: is a number of a regexp grouping whose text will be passed to CALLBACK. 6699 6700CALLBACK can also be a variable, in that case the value of that 6701variable it the real callback function." 6702 :group 'gnus-article-buttons 6703 :type '(repeat (list (choice regexp variable sexp) 6704 (integer :tag "Button") 6705 (sexp :tag "Form") 6706 (function :tag "Callback") 6707 (repeat :tag "Par" 6708 :inline t 6709 (integer :tag "Regexp group"))))) 6710 6711(defcustom gnus-header-button-alist 6712 '(("^\\(References\\|Message-I[Dd]\\|^In-Reply-To\\):" "<[^<>]+>" 6713 0 (>= gnus-button-message-level 0) gnus-button-message-id 0) 6714 ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 6715 1 (>= gnus-button-message-level 0) gnus-button-reply 1) 6716 ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+" 6717 0 (>= gnus-button-message-level 0) gnus-msg-mail 0) 6718 ("^X-[Uu][Rr][Ll]:" gnus-button-url-regexp 6719 0 (>= gnus-button-browse-level 0) browse-url 0) 6720 ("^Subject:" gnus-button-url-regexp 6721 0 (>= gnus-button-browse-level 0) browse-url 0) 6722 ("^[^:]+:" gnus-button-url-regexp 6723 0 (>= gnus-button-browse-level 0) browse-url 0) 6724 ("^[^:]+:" "\\bmailto:\\([-a-z.@_+0-9%=?&/]+\\)" 6725 0 (>= gnus-button-message-level 0) gnus-url-mailto 1) 6726 ("^[^:]+:" "\\(<\\(url: \\)?\\(nntp\\|news\\):\\([^>\n ]*\\)>\\)" 6727 1 (>= gnus-button-message-level 0) gnus-button-message-id 4)) 6728 "*Alist of headers and regexps to match buttons in article heads. 6729 6730This alist is very similar to `gnus-button-alist', except that each 6731alist has an additional HEADER element first in each entry: 6732 6733\(HEADER REGEXP BUTTON FORM CALLBACK PAR) 6734 6735HEADER is a regexp to match a header. For a fuller explanation, see 6736`gnus-button-alist'." 6737 :group 'gnus-article-buttons 6738 :group 'gnus-article-headers 6739 :type '(repeat (list (regexp :tag "Header") 6740 (choice regexp variable) 6741 (integer :tag "Button") 6742 (sexp :tag "Form") 6743 (function :tag "Callback") 6744 (repeat :tag "Par" 6745 :inline t 6746 (integer :tag "Regexp group"))))) 6747 6748;;; Commands: 6749 6750(defun gnus-article-push-button (event) 6751 "Check text under the mouse pointer for a callback function. 6752If the text under the mouse pointer has a `gnus-callback' property, 6753call it with the value of the `gnus-data' text property." 6754 (interactive "e") 6755 (set-buffer (window-buffer (posn-window (event-start event)))) 6756 (let* ((pos (posn-point (event-start event))) 6757 (data (get-text-property pos 'gnus-data)) 6758 (fun (get-text-property pos 'gnus-callback))) 6759 (goto-char pos) 6760 (when fun 6761 (funcall fun data)))) 6762 6763(defun gnus-article-press-button () 6764 "Check text at point for a callback function. 6765If the text at point has a `gnus-callback' property, 6766call it with the value of the `gnus-data' text property." 6767 (interactive) 6768 (let ((data (get-text-property (point) 'gnus-data)) 6769 (fun (get-text-property (point) 'gnus-callback))) 6770 (when fun 6771 (funcall fun data)))) 6772 6773(defun gnus-article-highlight (&optional force) 6774 "Highlight current article. 6775This function calls `gnus-article-highlight-headers', 6776`gnus-article-highlight-citation', 6777`gnus-article-highlight-signature', and `gnus-article-add-buttons' to 6778do the highlighting. See the documentation for those functions." 6779 (interactive (list 'force)) 6780 (gnus-article-highlight-headers) 6781 (gnus-article-highlight-citation force) 6782 (gnus-article-highlight-signature) 6783 (gnus-article-add-buttons force) 6784 (gnus-article-add-buttons-to-head)) 6785 6786(defun gnus-article-highlight-some (&optional force) 6787 "Highlight current article. 6788This function calls `gnus-article-highlight-headers', 6789`gnus-article-highlight-signature', and `gnus-article-add-buttons' to 6790do the highlighting. See the documentation for those functions." 6791 (interactive (list 'force)) 6792 (gnus-article-highlight-headers) 6793 (gnus-article-highlight-signature) 6794 (gnus-article-add-buttons)) 6795 6796(defun gnus-article-highlight-headers () 6797 "Highlight article headers as specified by `gnus-header-face-alist'." 6798 (interactive) 6799 (save-excursion 6800 (set-buffer gnus-article-buffer) 6801 (save-restriction 6802 (let ((alist gnus-header-face-alist) 6803 (inhibit-read-only t) 6804 (case-fold-search t) 6805 (inhibit-point-motion-hooks t) 6806 entry regexp header-face field-face from hpoints fpoints) 6807 (article-narrow-to-head) 6808 (while (setq entry (pop alist)) 6809 (goto-char (point-min)) 6810 (setq regexp (concat "^\\(" 6811 (if (string-equal "" (nth 0 entry)) 6812 "[^\t ]" 6813 (nth 0 entry)) 6814 "\\)") 6815 header-face (nth 1 entry) 6816 field-face (nth 2 entry)) 6817 (while (and (re-search-forward regexp nil t) 6818 (not (eobp))) 6819 (beginning-of-line) 6820 (setq from (point)) 6821 (unless (search-forward ":" nil t) 6822 (forward-char 1)) 6823 (when (and header-face 6824 (not (memq (point) hpoints))) 6825 (push (point) hpoints) 6826 (gnus-put-text-property from (point) 'face header-face)) 6827 (when (and field-face 6828 (not (memq (setq from (point)) fpoints))) 6829 (push from fpoints) 6830 (if (re-search-forward "^[^ \t]" nil t) 6831 (forward-char -2) 6832 (goto-char (point-max))) 6833 (gnus-put-text-property from (point) 'face field-face)))))))) 6834 6835(defun gnus-article-highlight-signature () 6836 "Highlight the signature in an article. 6837It does this by highlighting everything after 6838`gnus-signature-separator' using the face `gnus-signature'." 6839 (interactive) 6840 (save-excursion 6841 (set-buffer gnus-article-buffer) 6842 (let ((inhibit-read-only t) 6843 (inhibit-point-motion-hooks t)) 6844 (save-restriction 6845 (when (and gnus-signature-face 6846 (gnus-article-narrow-to-signature)) 6847 (gnus-overlay-put (gnus-make-overlay (point-min) (point-max)) 6848 'face gnus-signature-face) 6849 (widen) 6850 (gnus-article-search-signature) 6851 (let ((start (match-beginning 0)) 6852 (end (set-marker (make-marker) (1+ (match-end 0))))) 6853 (gnus-article-add-button start (1- end) 'gnus-signature-toggle 6854 end))))))) 6855 6856(defun gnus-button-in-region-p (b e prop) 6857 "Say whether PROP exists in the region." 6858 (text-property-not-all b e prop nil)) 6859 6860(defun gnus-article-add-buttons (&optional force) 6861 "Find external references in the article and make buttons of them. 6862\"External references\" are things like Message-IDs and URLs, as 6863specified by `gnus-button-alist'." 6864 (interactive (list 'force)) 6865 (save-excursion 6866 (set-buffer gnus-article-buffer) 6867 (let ((inhibit-read-only t) 6868 (inhibit-point-motion-hooks t) 6869 (case-fold-search t) 6870 (alist gnus-button-alist) 6871 beg entry regexp) 6872 ;; Remove all old markers. 6873 (let (marker entry new-list) 6874 (while (setq marker (pop gnus-button-marker-list)) 6875 (if (or (< marker (point-min)) (>= marker (point-max))) 6876 (push marker new-list) 6877 (goto-char marker) 6878 (when (setq entry (gnus-button-entry)) 6879 (put-text-property (match-beginning (nth 1 entry)) 6880 (match-end (nth 1 entry)) 6881 'gnus-callback nil)) 6882 (set-marker marker nil))) 6883 (setq gnus-button-marker-list new-list)) 6884 ;; We skip the headers. 6885 (article-goto-body) 6886 (setq beg (point)) 6887 (while (setq entry (pop alist)) 6888 (setq regexp (eval (car entry))) 6889 (goto-char beg) 6890 (while (re-search-forward regexp nil t) 6891 (let* ((start (and entry (match-beginning (nth 1 entry)))) 6892 (end (and entry (match-end (nth 1 entry)))) 6893 (from (match-beginning 0))) 6894 (when (and (or (eq t (nth 2 entry)) 6895 (eval (nth 2 entry))) 6896 (not (gnus-button-in-region-p 6897 start end 'gnus-callback))) 6898 ;; That optional form returned non-nil, so we add the 6899 ;; button. 6900 (gnus-article-add-button 6901 start end 'gnus-button-push 6902 (car (push (set-marker (make-marker) from) 6903 gnus-button-marker-list)))))))))) 6904 6905;; Add buttons to the head of an article. 6906(defun gnus-article-add-buttons-to-head () 6907 "Add buttons to the head of the article." 6908 (interactive) 6909 (save-excursion 6910 (set-buffer gnus-article-buffer) 6911 (save-restriction 6912 (let ((inhibit-read-only t) 6913 (inhibit-point-motion-hooks t) 6914 (case-fold-search t) 6915 (alist gnus-header-button-alist) 6916 entry beg end) 6917 (article-narrow-to-head) 6918 (while alist 6919 ;; Each alist entry. 6920 (setq entry (car alist) 6921 alist (cdr alist)) 6922 (goto-char (point-min)) 6923 (while (re-search-forward (car entry) nil t) 6924 ;; Each header matching the entry. 6925 (setq beg (match-beginning 0)) 6926 (setq end (or (and (re-search-forward "^[^ \t]" nil t) 6927 (match-beginning 0)) 6928 (point-max))) 6929 (goto-char beg) 6930 (while (re-search-forward (eval (nth 1 entry)) end t) 6931 ;; Each match within a header. 6932 (let* ((entry (cdr entry)) 6933 (start (match-beginning (nth 1 entry))) 6934 (end (match-end (nth 1 entry))) 6935 (form (nth 2 entry))) 6936 (goto-char (match-end 0)) 6937 (when (eval form) 6938 (gnus-article-add-button 6939 start end (nth 3 entry) 6940 (buffer-substring (match-beginning (nth 4 entry)) 6941 (match-end (nth 4 entry))))))) 6942 (goto-char end))))))) 6943 6944;;; External functions: 6945 6946(defun gnus-article-add-button (from to fun &optional data) 6947 "Create a button between FROM and TO with callback FUN and data DATA." 6948 (when gnus-article-button-face 6949 (gnus-overlay-put (gnus-make-overlay from to) 6950 'face gnus-article-button-face)) 6951 (gnus-add-text-properties 6952 from to 6953 (nconc (and gnus-article-mouse-face 6954 (list gnus-mouse-face-prop gnus-article-mouse-face)) 6955 (list 'gnus-callback fun) 6956 (and data (list 'gnus-data data)))) 6957 (widget-convert-button 'link from to :action 'gnus-widget-press-button 6958 :button-keymap gnus-widget-button-keymap)) 6959 6960;;; Internal functions: 6961 6962(defun gnus-article-set-globals () 6963 (save-excursion 6964 (set-buffer gnus-summary-buffer) 6965 (gnus-set-global-variables))) 6966 6967(defun gnus-signature-toggle (end) 6968 (save-excursion 6969 (set-buffer gnus-article-buffer) 6970 (let ((inhibit-read-only t) 6971 (inhibit-point-motion-hooks t)) 6972 (if (text-property-any end (point-max) 'article-type 'signature) 6973 (progn 6974 (gnus-delete-wash-type 'signature) 6975 (gnus-remove-text-properties-when 6976 'article-type 'signature end (point-max) 6977 (cons 'article-type (cons 'signature 6978 gnus-hidden-properties)))) 6979 (gnus-add-wash-type 'signature) 6980 (gnus-add-text-properties-when 6981 'article-type nil end (point-max) 6982 (cons 'article-type (cons 'signature 6983 gnus-hidden-properties))))) 6984 (let ((gnus-article-mime-handle-alist-1 gnus-article-mime-handle-alist)) 6985 (gnus-set-mode-line 'article)))) 6986 6987(defun gnus-button-entry () 6988 ;; Return the first entry in `gnus-button-alist' matching this place. 6989 (let ((alist gnus-button-alist) 6990 (entry nil)) 6991 (while alist 6992 (setq entry (pop alist)) 6993 (if (looking-at (eval (car entry))) 6994 (setq alist nil) 6995 (setq entry nil))) 6996 entry)) 6997 6998(defun gnus-button-push (marker) 6999 ;; Push button starting at MARKER. 7000 (save-excursion 7001 (goto-char marker) 7002 (let* ((entry (gnus-button-entry)) 7003 (inhibit-point-motion-hooks t) 7004 (fun (nth 3 entry)) 7005 (args (mapcar (lambda (group) 7006 (let ((string (match-string group))) 7007 (gnus-set-text-properties 7008 0 (length string) nil string) 7009 string)) 7010 (nthcdr 4 entry)))) 7011 (cond 7012 ((fboundp fun) 7013 (apply fun args)) 7014 ((and (boundp fun) 7015 (fboundp (symbol-value fun))) 7016 (apply (symbol-value fun) args)) 7017 (t 7018 (gnus-message 1 "You must define `%S' to use this button" 7019 (cons fun args))))))) 7020 7021(defun gnus-parse-news-url (url) 7022 (let (scheme server port group message-id articles) 7023 (with-temp-buffer 7024 (insert url) 7025 (goto-char (point-min)) 7026 (when (looking-at "\\([A-Za-z]+\\):") 7027 (setq scheme (match-string 1)) 7028 (goto-char (match-end 0))) 7029 (when (looking-at "//\\([^:/]+\\)\\(:?\\)\\([0-9]+\\)?/") 7030 (setq server (match-string 1)) 7031 (setq port (if (stringp (match-string 3)) 7032 (string-to-number (match-string 3)) 7033 (match-string 3))) 7034 (goto-char (match-end 0))) 7035 7036 (cond 7037 ((looking-at "\\(.*@.*\\)") 7038 (setq message-id (match-string 1))) 7039 ((looking-at "\\([^/]+\\)/\\([-0-9]+\\)") 7040 (setq group (match-string 1) 7041 articles (split-string (match-string 2) "-"))) 7042 ((looking-at "\\([^/]+\\)/?") 7043 (setq group (match-string 1))) 7044 (t 7045 (error "Unknown news URL syntax")))) 7046 (list scheme server port group message-id articles))) 7047 7048(defun gnus-button-handle-news (url) 7049 "Fetch a news URL." 7050 (destructuring-bind (scheme server port group message-id articles) 7051 (gnus-parse-news-url url) 7052 (cond 7053 (message-id 7054 (save-excursion 7055 (set-buffer gnus-summary-buffer) 7056 (if server 7057 (let ((gnus-refer-article-method 7058 (nconc (list (list 'nntp server)) 7059 gnus-refer-article-method)) 7060 (nntp-port-number (or port "nntp"))) 7061 (gnus-message 7 "Fetching %s with %s" 7062 message-id gnus-refer-article-method) 7063 (gnus-summary-refer-article message-id)) 7064 (gnus-summary-refer-article message-id)))) 7065 (group 7066 (gnus-button-fetch-group url))))) 7067 7068(defun gnus-button-handle-man (url) 7069 "Fetch a man page." 7070 (gnus-message 9 "`%s' `%s'" gnus-button-man-handler url) 7071 (when (eq gnus-button-man-handler 'woman) 7072 (setq url (gnus-replace-in-string url "([1-9][X1a-z]*).*\\'" ""))) 7073 (gnus-message 9 "`%s' `%s'" gnus-button-man-handler url) 7074 (funcall gnus-button-man-handler url)) 7075 7076(defun gnus-button-handle-info-url (url) 7077 "Fetch an info URL." 7078 (setq url (mm-subst-char-in-string ?+ ?\ url)) 7079 (cond 7080 ((string-match "^\\([^:/]+\\)?/\\(.*\\)" url) 7081 (gnus-info-find-node 7082 (concat "(" (or (gnus-url-unhex-string (match-string 1 url)) 7083 "Gnus") 7084 ")" (gnus-url-unhex-string (match-string 2 url))))) 7085 ((string-match "([^)\"]+)[^\"]+" url) 7086 (setq url 7087 (gnus-replace-in-string 7088 (gnus-replace-in-string url "[\n\t ]+" " ") "\"" "")) 7089 (gnus-info-find-node url)) 7090 (t (error "Can't parse %s" url)))) 7091 7092(defun gnus-button-handle-info-url-gnome (url) 7093 "Fetch GNOME style info URL." 7094 (setq url (mm-subst-char-in-string ?_ ?\ url)) 7095 (if (string-match "\\([^#]+\\)#?\\(.*\\)" url) 7096 (gnus-info-find-node 7097 (concat "(" 7098 (gnus-url-unhex-string 7099 (match-string 1 url)) 7100 ")" 7101 (or (gnus-url-unhex-string 7102 (match-string 2 url)) 7103 "Top"))) 7104 (error "Can't parse %s" url))) 7105 7106(defun gnus-button-handle-info-url-kde (url) 7107 "Fetch KDE style info URL." 7108 (gnus-info-find-node (gnus-url-unhex-string url))) 7109 7110(defun gnus-button-handle-info-keystrokes (url) 7111 "Call `info' when pushing the corresponding URL button." 7112 ;; For links like `C-h i d m gnus RET', `C-h i d m CC Mode RET'. 7113 (info) 7114 (Info-directory) 7115 (Info-menu url)) 7116 7117(defun gnus-button-message-id (message-id) 7118 "Fetch MESSAGE-ID." 7119 (save-excursion 7120 (set-buffer gnus-summary-buffer) 7121 (gnus-summary-refer-article message-id))) 7122 7123(defun gnus-button-fetch-group (address) 7124 "Fetch GROUP specified by ADDRESS." 7125 (if (not (string-match "[:/]" address)) 7126 ;; This is just a simple group url. 7127 (gnus-group-read-ephemeral-group address gnus-select-method) 7128 (if (not 7129 (string-match 7130 "^\\([^:/]+\\)\\(:\\([^/]+\\)\\)?/\\([^/]+\\)\\(/\\([0-9]+\\)\\)?" 7131 address)) 7132 (error "Can't parse %s" address) 7133 (gnus-group-read-ephemeral-group 7134 (match-string 4 address) 7135 `(nntp ,(match-string 1 address) 7136 (nntp-address ,(match-string 1 address)) 7137 (nntp-port-number ,(if (match-end 3) 7138 (match-string 3 address) 7139 "nntp"))) 7140 nil nil nil 7141 (and (match-end 6) (list (string-to-number (match-string 6 address)))))))) 7142 7143(defun gnus-url-parse-query-string (query &optional downcase) 7144 (let (retval pairs cur key val) 7145 (setq pairs (split-string query "&")) 7146 (while pairs 7147 (setq cur (car pairs) 7148 pairs (cdr pairs)) 7149 (if (not (string-match "=" cur)) 7150 nil ; Grace 7151 (setq key (gnus-url-unhex-string (substring cur 0 (match-beginning 0))) 7152 val (gnus-url-unhex-string (substring cur (match-end 0) nil) t)) 7153 (if downcase 7154 (setq key (downcase key))) 7155 (setq cur (assoc key retval)) 7156 (if cur 7157 (setcdr cur (cons val (cdr cur))) 7158 (setq retval (cons (list key val) retval))))) 7159 retval)) 7160 7161(defun gnus-url-mailto (url) 7162 ;; Send mail to someone 7163 (when (string-match "mailto:/*\\(.*\\)" url) 7164 (setq url (substring url (match-beginning 1) nil))) 7165 (let (to args subject func) 7166 (setq args (gnus-url-parse-query-string 7167 (if (string-match "^\\?" url) 7168 (substring url 1) 7169 (if (string-match "^\\([^?]+\\)\\?\\(.*\\)" url) 7170 (concat "to=" (match-string 1 url) "&" 7171 (match-string 2 url)) 7172 (concat "to=" url))) 7173 t) 7174 subject (cdr-safe (assoc "subject" args))) 7175 (gnus-msg-mail) 7176 (while args 7177 (setq func (intern-soft (concat "message-goto-" (downcase (caar args))))) 7178 (if (fboundp func) 7179 (funcall func) 7180 (message-position-on-field (caar args))) 7181 (insert (gnus-replace-in-string 7182 (mapconcat 'identity (reverse (cdar args)) ", ") 7183 "\r\n" "\n" t)) 7184 (setq args (cdr args))) 7185 (if subject 7186 (message-goto-body) 7187 (message-goto-subject)))) 7188 7189(defun gnus-button-embedded-url (address) 7190 "Activate ADDRESS with `browse-url'." 7191 (browse-url (gnus-strip-whitespace address))) 7192 7193;;; Next/prev buttons in the article buffer. 7194 7195(defvar gnus-next-page-line-format "%{%(Next page...%)%}\n") 7196(defvar gnus-prev-page-line-format "%{%(Previous page...%)%}\n") 7197 7198(defvar gnus-prev-page-map 7199 (let ((map (make-sparse-keymap))) 7200 (unless (>= emacs-major-version 21) 7201 ;; XEmacs doesn't care. 7202 (set-keymap-parent map gnus-article-mode-map)) 7203 (define-key map gnus-mouse-2 'gnus-button-prev-page) 7204 (define-key map "\r" 'gnus-button-prev-page) 7205 map)) 7206 7207(defvar gnus-next-page-map 7208 (let ((map (make-sparse-keymap))) 7209 (unless (>= emacs-major-version 21) 7210 ;; XEmacs doesn't care. 7211 (set-keymap-parent map gnus-article-mode-map)) 7212 (define-key map gnus-mouse-2 'gnus-button-next-page) 7213 (define-key map "\r" 'gnus-button-next-page) 7214 map)) 7215 7216(defun gnus-insert-prev-page-button () 7217 (let ((b (point)) 7218 (inhibit-read-only t)) 7219 (gnus-eval-format 7220 gnus-prev-page-line-format nil 7221 `(,@(gnus-local-map-property gnus-prev-page-map) 7222 gnus-prev t 7223 gnus-callback gnus-article-button-prev-page 7224 article-type annotation)) 7225 (widget-convert-button 7226 'link b (if (bolp) 7227 ;; Exclude a newline. 7228 (1- (point)) 7229 (point)) 7230 :action 'gnus-button-prev-page 7231 :button-keymap gnus-prev-page-map))) 7232 7233(defun gnus-button-next-page (&optional args more-args) 7234 "Go to the next page." 7235 (interactive) 7236 (let ((win (selected-window))) 7237 (select-window (gnus-get-buffer-window gnus-article-buffer t)) 7238 (gnus-article-next-page) 7239 (select-window win))) 7240 7241(defun gnus-button-prev-page (&optional args more-args) 7242 "Go to the prev page." 7243 (interactive) 7244 (let ((win (selected-window))) 7245 (select-window (gnus-get-buffer-window gnus-article-buffer t)) 7246 (gnus-article-prev-page) 7247 (select-window win))) 7248 7249(defun gnus-insert-next-page-button () 7250 (let ((b (point)) 7251 (inhibit-read-only t)) 7252 (gnus-eval-format gnus-next-page-line-format nil 7253 `(,@(gnus-local-map-property gnus-next-page-map) 7254 gnus-next t 7255 gnus-callback gnus-article-button-next-page 7256 article-type annotation)) 7257 (widget-convert-button 7258 'link b (if (bolp) 7259 ;; Exclude a newline. 7260 (1- (point)) 7261 (point)) 7262 :action 'gnus-button-next-page 7263 :button-keymap gnus-next-page-map))) 7264 7265(defun gnus-article-button-next-page (arg) 7266 "Go to the next page." 7267 (interactive "P") 7268 (let ((win (selected-window))) 7269 (select-window (gnus-get-buffer-window gnus-article-buffer t)) 7270 (gnus-article-next-page) 7271 (select-window win))) 7272 7273(defun gnus-article-button-prev-page (arg) 7274 "Go to the prev page." 7275 (interactive "P") 7276 (let ((win (selected-window))) 7277 (select-window (gnus-get-buffer-window gnus-article-buffer t)) 7278 (gnus-article-prev-page) 7279 (select-window win))) 7280 7281(defvar gnus-decode-header-methods 7282 '(mail-decode-encoded-word-region) 7283 "List of methods used to decode headers. 7284 7285This variable is a list of FUNCTION or (REGEXP . FUNCTION). If item 7286is FUNCTION, FUNCTION will be applied to all newsgroups. If item is a 7287\(REGEXP . FUNCTION), FUNCTION will be only apply to the newsgroups 7288whose names match REGEXP. 7289 7290For example: 7291\((\"chinese\" . gnus-decode-encoded-word-region-by-guess) 7292 mail-decode-encoded-word-region 7293 (\"chinese\" . rfc1843-decode-region)) 7294") 7295 7296(defvar gnus-decode-header-methods-cache nil) 7297 7298(defun gnus-multi-decode-header (start end) 7299 "Apply the functions from `gnus-encoded-word-methods' that match." 7300 (unless (and gnus-decode-header-methods-cache 7301 (eq gnus-newsgroup-name 7302 (car gnus-decode-header-methods-cache))) 7303 (setq gnus-decode-header-methods-cache (list gnus-newsgroup-name)) 7304 (mapcar (lambda (x) 7305 (if (symbolp x) 7306 (nconc gnus-decode-header-methods-cache (list x)) 7307 (if (and gnus-newsgroup-name 7308 (string-match (car x) gnus-newsgroup-name)) 7309 (nconc gnus-decode-header-methods-cache 7310 (list (cdr x)))))) 7311 gnus-decode-header-methods)) 7312 (let ((xlist gnus-decode-header-methods-cache)) 7313 (pop xlist) 7314 (save-restriction 7315 (narrow-to-region start end) 7316 (while xlist 7317 (funcall (pop xlist) (point-min) (point-max)))))) 7318 7319;;; 7320;;; Treatment top-level handling. 7321;;; 7322 7323(defun gnus-treat-article (condition &optional part-number total-parts type) 7324 (let ((length (- (point-max) (point-min))) 7325 (alist gnus-treatment-function-alist) 7326 (article-goto-body-goes-to-point-min-p t) 7327 (treated-type 7328 (or (not type) 7329 (catch 'found 7330 (let ((list gnus-article-treat-types)) 7331 (while list 7332 (when (string-match (pop list) type) 7333 (throw 'found t))))))) 7334 (highlightp (gnus-visual-p 'article-highlight 'highlight)) 7335 val elem) 7336 (gnus-run-hooks 'gnus-part-display-hook) 7337 (dolist (elem alist) 7338 (setq val 7339 (save-excursion 7340 (when (gnus-buffer-live-p gnus-summary-buffer) 7341 (set-buffer gnus-summary-buffer)) 7342 (symbol-value (car elem)))) 7343 (when (and (or (consp val) 7344 treated-type) 7345 (gnus-treat-predicate val) 7346 (or (not (get (car elem) 'highlight)) 7347 highlightp)) 7348 (save-restriction 7349 (funcall (cadr elem))))))) 7350 7351;; Dynamic variables. 7352(eval-when-compile 7353 (defvar part-number) 7354 (defvar total-parts) 7355 (defvar type) 7356 (defvar condition) 7357 (defvar length)) 7358 7359(defun gnus-treat-predicate (val) 7360 (cond 7361 ((null val) 7362 nil) 7363 (condition 7364 (eq condition val)) 7365 ((and (listp val) 7366 (stringp (car val))) 7367 (apply 'gnus-or (mapcar `(lambda (s) 7368 (string-match s ,(or gnus-newsgroup-name ""))) 7369 val))) 7370 ((listp val) 7371 (let ((pred (pop val))) 7372 (cond 7373 ((eq pred 'or) 7374 (apply 'gnus-or (mapcar 'gnus-treat-predicate val))) 7375 ((eq pred 'and) 7376 (apply 'gnus-and (mapcar 'gnus-treat-predicate val))) 7377 ((eq pred 'not) 7378 (not (gnus-treat-predicate (car val)))) 7379 ((eq pred 'typep) 7380 (equal (car val) type)) 7381 (t 7382 (error "%S is not a valid predicate" pred))))) 7383 ((eq val t) 7384 t) 7385 ((eq val 'head) 7386 nil) 7387 ((eq val 'last) 7388 (eq part-number total-parts)) 7389 ((numberp val) 7390 (< length val)) 7391 (t 7392 (error "%S is not a valid value" val)))) 7393 7394(defun gnus-article-encrypt-body (protocol &optional n) 7395 "Encrypt the article body." 7396 (interactive 7397 (list 7398 (or gnus-article-encrypt-protocol 7399 (completing-read "Encrypt protocol: " 7400 gnus-article-encrypt-protocol-alist 7401 nil t)) 7402 current-prefix-arg)) 7403 (let ((func (cdr (assoc protocol gnus-article-encrypt-protocol-alist)))) 7404 (unless func 7405 (error "Can't find the encrypt protocol %s" protocol)) 7406 (if (member gnus-newsgroup-name '("nndraft:delayed" 7407 "nndraft:drafts" 7408 "nndraft:queue")) 7409 (error "Can't encrypt the article in group %s" 7410 gnus-newsgroup-name)) 7411 (gnus-summary-iterate n 7412 (save-excursion 7413 (set-buffer gnus-summary-buffer) 7414 (let ((mail-parse-charset gnus-newsgroup-charset) 7415 (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets) 7416 (summary-buffer gnus-summary-buffer) 7417 references point) 7418 (gnus-set-global-variables) 7419 (when (gnus-group-read-only-p) 7420 (error "The current newsgroup does not support article encrypt")) 7421 (gnus-summary-show-article t) 7422 (setq references 7423 (or (mail-header-references gnus-current-headers) "")) 7424 (set-buffer gnus-article-buffer) 7425 (let* ((inhibit-read-only t) 7426 (headers 7427 (mapcar (lambda (field) 7428 (and (save-restriction 7429 (message-narrow-to-head) 7430 (goto-char (point-min)) 7431 (search-forward field nil t)) 7432 (prog2 7433 (message-narrow-to-field) 7434 (buffer-string) 7435 (delete-region (point-min) (point-max)) 7436 (widen)))) 7437 '("Content-Type:" "Content-Transfer-Encoding:" 7438 "Content-Disposition:")))) 7439 (message-narrow-to-head) 7440 (message-remove-header "MIME-Version") 7441 (goto-char (point-max)) 7442 (setq point (point)) 7443 (insert (apply 'concat headers)) 7444 (widen) 7445 (narrow-to-region point (point-max)) 7446 (let ((message-options message-options)) 7447 (message-options-set 'message-sender user-mail-address) 7448 (message-options-set 'message-recipients user-mail-address) 7449 (message-options-set 'message-sign-encrypt 'not) 7450 (funcall func)) 7451 (goto-char (point-min)) 7452 (insert "MIME-Version: 1.0\n") 7453 (widen) 7454 (gnus-summary-edit-article-done 7455 references nil summary-buffer t)) 7456 (when gnus-keep-backlog 7457 (gnus-backlog-remove-article 7458 (car gnus-article-current) (cdr gnus-article-current))) 7459 (save-excursion 7460 (when (get-buffer gnus-original-article-buffer) 7461 (set-buffer gnus-original-article-buffer) 7462 (setq gnus-original-article nil))) 7463 (when gnus-use-cache 7464 (gnus-cache-update-article 7465 (car gnus-article-current) (cdr gnus-article-current)))))))) 7466 7467(defvar gnus-mime-security-button-line-format "%{%([[%t:%i]%D]%)%}\n" 7468 "The following specs can be used: 7469%t The security MIME type 7470%i Additional info 7471%d Details 7472%D Details if button is pressed") 7473 7474(defvar gnus-mime-security-button-end-line-format "%{%([[End of %t]%D]%)%}\n" 7475 "The following specs can be used: 7476%t The security MIME type 7477%i Additional info 7478%d Details 7479%D Details if button is pressed") 7480 7481(defvar gnus-mime-security-button-line-format-alist 7482 '((?t gnus-tmp-type ?s) 7483 (?i gnus-tmp-info ?s) 7484 (?d gnus-tmp-details ?s) 7485 (?D gnus-tmp-pressed-details ?s))) 7486 7487(defvar gnus-mime-security-button-map 7488 (let ((map (make-sparse-keymap))) 7489 (unless (>= (string-to-number emacs-version) 21) 7490 (set-keymap-parent map gnus-article-mode-map)) 7491 (define-key map gnus-mouse-2 'gnus-article-push-button) 7492 (define-key map "\r" 'gnus-article-press-button) 7493 map)) 7494 7495(defvar gnus-mime-security-details-buffer nil) 7496 7497(defvar gnus-mime-security-button-pressed nil) 7498 7499(defvar gnus-mime-security-show-details-inline t 7500 "If non-nil, show details in the article buffer.") 7501 7502(defun gnus-mime-security-verify-or-decrypt (handle) 7503 (mm-remove-parts (cdr handle)) 7504 (let ((region (mm-handle-multipart-ctl-parameter handle 'gnus-region)) 7505 point (inhibit-read-only t)) 7506 (if region 7507 (goto-char (car region))) 7508 (save-restriction 7509 (narrow-to-region (point) (point)) 7510 (with-current-buffer (mm-handle-multipart-original-buffer handle) 7511 (let* ((mm-verify-option 'known) 7512 (mm-decrypt-option 'known) 7513 (nparts (mm-possibly-verify-or-decrypt (cdr handle) handle))) 7514 (unless (eq nparts (cdr handle)) 7515 (mm-destroy-parts (cdr handle)) 7516 (setcdr handle nparts)))) 7517 (setq point (point)) 7518 (gnus-mime-display-security handle) 7519 (goto-char (point-max))) 7520 (when region 7521 (delete-region (point) (cdr region)) 7522 (set-marker (car region) nil) 7523 (set-marker (cdr region) nil)) 7524 (goto-char point))) 7525 7526(defun gnus-mime-security-show-details (handle) 7527 (let ((details (mm-handle-multipart-ctl-parameter handle 'gnus-details))) 7528 (if (not details) 7529 (gnus-message 5 "No details.") 7530 (if gnus-mime-security-show-details-inline 7531 (let ((gnus-mime-security-button-pressed 7532 (not (get-text-property (point) 'gnus-mime-details))) 7533 (gnus-mime-security-button-line-format 7534 (get-text-property (point) 'gnus-line-format)) 7535 (inhibit-read-only t)) 7536 (forward-char -1) 7537 (while (eq (get-text-property (point) 'gnus-line-format) 7538 gnus-mime-security-button-line-format) 7539 (forward-char -1)) 7540 (forward-char) 7541 (save-restriction 7542 (narrow-to-region (point) (point)) 7543 (gnus-insert-mime-security-button handle)) 7544 (delete-region (point) 7545 (or (text-property-not-all 7546 (point) (point-max) 7547 'gnus-line-format 7548 gnus-mime-security-button-line-format) 7549 (point-max)))) 7550 ;; Not inlined. 7551 (if (gnus-buffer-live-p gnus-mime-security-details-buffer) 7552 (with-current-buffer gnus-mime-security-details-buffer 7553 (erase-buffer) 7554 t) 7555 (setq gnus-mime-security-details-buffer 7556 (gnus-get-buffer-create "*MIME Security Details*"))) 7557 (with-current-buffer gnus-mime-security-details-buffer 7558 (insert details) 7559 (goto-char (point-min))) 7560 (pop-to-buffer gnus-mime-security-details-buffer))))) 7561 7562(defun gnus-mime-security-press-button (handle) 7563 (save-excursion 7564 (if (mm-handle-multipart-ctl-parameter handle 'gnus-info) 7565 (gnus-mime-security-show-details handle) 7566 (gnus-mime-security-verify-or-decrypt handle)))) 7567 7568(defun gnus-insert-mime-security-button (handle &optional displayed) 7569 (let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol)) 7570 (gnus-tmp-type 7571 (concat 7572 (or (nth 2 (assoc protocol mm-verify-function-alist)) 7573 (nth 2 (assoc protocol mm-decrypt-function-alist)) 7574 "Unknown") 7575 (if (equal (car handle) "multipart/signed") 7576 " Signed" " Encrypted") 7577 " Part")) 7578 (gnus-tmp-info 7579 (or (mm-handle-multipart-ctl-parameter handle 'gnus-info) 7580 "Undecided")) 7581 (gnus-tmp-details 7582 (mm-handle-multipart-ctl-parameter handle 'gnus-details)) 7583 gnus-tmp-pressed-details 7584 b e) 7585 (setq gnus-tmp-details 7586 (if gnus-tmp-details 7587 (concat "\n" gnus-tmp-details) 7588 "")) 7589 (setq gnus-tmp-pressed-details 7590 (if gnus-mime-security-button-pressed gnus-tmp-details "")) 7591 (unless (bolp) 7592 (insert "\n")) 7593 (setq b (point)) 7594 (gnus-eval-format 7595 gnus-mime-security-button-line-format 7596 gnus-mime-security-button-line-format-alist 7597 `(,@(gnus-local-map-property gnus-mime-security-button-map) 7598 gnus-callback gnus-mime-security-press-button 7599 gnus-line-format ,gnus-mime-security-button-line-format 7600 gnus-mime-details ,gnus-mime-security-button-pressed 7601 article-type annotation 7602 gnus-data ,handle)) 7603 (setq e (if (bolp) 7604 ;; Exclude a newline. 7605 (1- (point)) 7606 (point))) 7607 (widget-convert-button 7608 'link b e 7609 :mime-handle handle 7610 :action 'gnus-widget-press-button 7611 :button-keymap gnus-mime-security-button-map 7612 :help-echo 7613 (lambda (widget/window &optional overlay pos) 7614 ;; Needed to properly clear the message due to a bug in 7615 ;; wid-edit (XEmacs only). 7616 (when (boundp 'help-echo-owns-message) 7617 (setq help-echo-owns-message t)) 7618 (format 7619 "%S: show detail" 7620 (aref gnus-mouse-2 0)))))) 7621 7622(defun gnus-mime-display-security (handle) 7623 (save-restriction 7624 (narrow-to-region (point) (point)) 7625 (unless (gnus-unbuttonized-mime-type-p (car handle)) 7626 (gnus-insert-mime-security-button handle)) 7627 (gnus-mime-display-mixed (cdr handle)) 7628 (unless (bolp) 7629 (insert "\n")) 7630 (unless (gnus-unbuttonized-mime-type-p (car handle)) 7631 (let ((gnus-mime-security-button-line-format 7632 gnus-mime-security-button-end-line-format)) 7633 (gnus-insert-mime-security-button handle))) 7634 (mm-set-handle-multipart-parameter 7635 handle 'gnus-region 7636 (cons (set-marker (make-marker) (point-min)) 7637 (set-marker (make-marker) (point-max)))))) 7638 7639(gnus-ems-redefine) 7640 7641(provide 'gnus-art) 7642 7643(run-hooks 'gnus-art-load-hook) 7644 7645;;; arch-tag: 2654516f-6279-48f9-a83b-05c1fa450c33 7646;;; gnus-art.el ends here 7647