1 ;;; gnus-art.el --- article mode commands for Gnus
3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
9 ;; This file is part of GNU Emacs.
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 3 of the License, or
14 ;; (at your option) any later version.
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.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
30 (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
34 (defvar w3m-minor-mode-map)
37 ;; Avoid the "Recursive load suspected" error in Emacs 21.1.
39 (let ((recursive-load-depth-limit 100))
52 (autoload 'gnus-msg-mail "gnus-msg" nil t)
53 (autoload 'gnus-button-mailto "gnus-msg")
54 (autoload 'gnus-button-reply "gnus-msg" nil t)
55 (autoload 'parse-time-string "parse-time" nil nil)
56 (autoload 'ansi-color-apply-on-region "ansi-color")
57 (autoload 'mm-url-insert-file-contents-external "mm-url")
58 (autoload 'mm-extern-cache-contents "mm-extern")
60 (defgroup gnus-article nil
62 :link '(custom-manual "(gnus)Article Buffer")
65 (defgroup gnus-article-treat nil
66 "Treating article parts."
67 :link '(custom-manual "(gnus)Article Hiding")
70 (defgroup gnus-article-hiding nil
71 "Hiding article parts."
72 :link '(custom-manual "(gnus)Article Hiding")
75 (defgroup gnus-article-highlight nil
76 "Article highlighting."
77 :link '(custom-manual "(gnus)Article Highlighting")
81 (defgroup gnus-article-signature nil
83 :link '(custom-manual "(gnus)Article Signature")
86 (defgroup gnus-article-headers nil
88 :link '(custom-manual "(gnus)Hiding Headers")
91 (defgroup gnus-article-washing nil
92 "Special commands on articles."
93 :link '(custom-manual "(gnus)Article Washing")
96 (defgroup gnus-article-emphasis nil
97 "Fontisizing articles."
98 :link '(custom-manual "(gnus)Article Fontisizing")
101 (defgroup gnus-article-saving nil
103 :link '(custom-manual "(gnus)Saving Articles")
104 :group 'gnus-article)
106 (defgroup gnus-article-mime nil
107 "Worshiping the MIME wonder."
108 :link '(custom-manual "(gnus)Using MIME")
109 :group 'gnus-article)
111 (defgroup gnus-article-buttons nil
112 "Pushable buttons in the article buffer."
113 :link '(custom-manual "(gnus)Article Buttons")
114 :group 'gnus-article)
116 (defgroup gnus-article-various nil
117 "Other article options."
118 :link '(custom-manual "(gnus)Misc Article")
119 :group 'gnus-article)
121 (defcustom gnus-ignored-headers
124 (concat "^" header ":"))
125 '("Path" "Expires" "Date-Received" "References" "Xref" "Lines"
126 "Relay-Version" "Message-ID" "Approved" "Sender" "Received"
127 "X-UIDL" "MIME-Version" "Return-Path" "In-Reply-To"
128 "Content-Type" "Content-Transfer-Encoding" "X-WebTV-Signature"
129 "X-MimeOLE" "X-MSMail-Priority" "X-Priority" "X-Loop"
130 "X-Authentication-Warning" "X-MIME-Autoconverted" "X-Face"
131 "X-Attribution" "X-Originating-IP" "Delivered-To"
132 "NNTP-[-A-Za-z]+" "Distribution" "X-no-archive" "X-Trace"
133 "X-Complaints-To" "X-NNTP-Posting-Host" "X-Orig.*"
134 "Abuse-Reports-To" "Cache-Post-Path" "X-Article-Creation-Date"
135 "X-Poster" "X-Mail2News-Path" "X-Server-Date" "X-Cache"
136 "Originator" "X-Problems-To" "X-Auth-User" "X-Post-Time"
137 "X-Admin" "X-UID" "Resent-[-A-Za-z]+" "X-Mailing-List"
138 "Precedence" "Original-[-A-Za-z]+" "X-filename" "X-Orcpt"
139 "Old-Received" "X-Pgp" "X-Auth" "X-From-Line"
140 "X-Gnus-Article-Number" "X-Majordomo" "X-Url" "X-Sender"
141 "MBOX-Line" "Priority" "X400-[-A-Za-z]+"
142 "Status" "X-Gnus-Mail-Source" "Cancel-Lock"
143 "X-FTN" "X-EXP32-SerialNo" "Encoding" "Importance"
144 "Autoforwarded" "Original-Encoded-Information-Types" "X-Ya-Pop3"
145 "X-Face-Version" "X-Vms-To" "X-ML-NAME" "X-ML-COUNT"
146 "Mailing-List" "X-finfo" "X-md5sum" "X-md5sum-Origin"
147 "X-Sun-Charset" "X-Accept-Language" "X-Envelope-Sender"
148 "List-[A-Za-z]+" "X-Listprocessor-Version"
149 "X-Received" "X-Distribute" "X-Sequence" "X-Juno-Line-Breaks"
150 "X-Notes-Item" "X-MS-TNEF-Correlator" "x-uunet-gateway"
151 "X-Received" "Content-length" "X-precedence"
152 "X-Authenticated-User" "X-Comment" "X-Report" "X-Abuse-Info"
153 "X-HTTP-Proxy" "X-Mydeja-Info" "X-Copyright" "X-No-Markup"
154 "X-Abuse-Info" "X-From_" "X-Accept-Language" "Errors-To"
155 "X-BeenThere" "X-Mailman-Version" "List-Help" "List-Post"
156 "List-Subscribe" "List-Id" "List-Unsubscribe" "List-Archive"
157 "X-Content-length" "X-Posting-Agent" "Original-Received"
158 "X-Request-PGP" "X-Fingerprint" "X-WRIEnvto" "X-WRIEnvfrom"
159 "X-Virus-Scanned" "X-Delivery-Agent" "Posted-Date" "X-Gateway"
160 "X-Local-Origin" "X-Local-Destination" "X-UserInfo1"
161 "X-Received-Date" "X-Hashcash" "Face" "X-DMCA-Notifications"
162 "X-Abuse-and-DMCA-Info" "X-Postfilter" "X-Gpg-.*" "X-Disclaimer"
163 "Envelope-To" "X-Spam-Score" "System-Type" "X-Injected-Via-Gmane"
164 "X-Gmane-NNTP-Posting-Host" "Jabber-ID" "Archived-At"
165 "Envelope-Sender" "Envelope-Recipients"))
166 "*All headers that start with this regexp will be hidden.
167 This variable can also be a list of regexps of headers to be ignored.
168 If `gnus-visible-headers' is non-nil, this variable will be ignored."
169 :type '(choice :custom-show nil
172 :group 'gnus-article-hiding)
174 (defcustom gnus-visible-headers
175 "^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:"
176 "*All headers that do not match this regexp will be hidden.
177 This variable can also be a list of regexp of headers to remain visible.
178 If this variable is non-nil, `gnus-ignored-headers' will be ignored."
180 (repeat :value-to-internal (lambda (widget value)
181 (custom-split-regexp-maybe value))
182 :match (lambda (widget value)
184 (widget-editable-list-match widget value)))
186 (const :tag "Use gnus-ignored-headers" nil)
188 :group 'gnus-article-hiding)
190 (defcustom gnus-sorted-header-list
191 '("^From:" "^Subject:" "^Summary:" "^Keywords:" "^Newsgroups:"
192 "^Followup-To:" "^To:" "^Cc:" "^Date:" "^Organization:")
193 "*This variable is a list of regular expressions.
194 If it is non-nil, headers that match the regular expressions will
195 be placed first in the article buffer in the sequence specified by
197 :type '(repeat regexp)
198 :group 'gnus-article-hiding)
200 (defcustom gnus-boring-article-headers '(empty followup-to reply-to)
201 "Headers that are only to be displayed if they have interesting data.
202 Possible values in this list are:
204 'empty Headers with no content.
205 'newsgroups Newsgroup identical to Gnus group.
206 'to-address To identical to To-address.
207 'to-list To identical to To-list.
208 'cc-list CC identical to To-list.
209 'followup-to Followup-to identical to Newsgroups.
210 'reply-to Reply-to identical to From.
211 'date Date less than four days old.
212 'long-to To and/or Cc longer than 1024 characters.
213 'many-to Multiple To and/or Cc."
214 :type '(set (const :tag "Headers with no content." empty)
215 (const :tag "Newsgroups identical to Gnus group." newsgroups)
216 (const :tag "To identical to To-address." to-address)
217 (const :tag "To identical to To-list." to-list)
218 (const :tag "CC identical to To-list." cc-list)
219 (const :tag "Followup-to identical to Newsgroups." followup-to)
220 (const :tag "Reply-to identical to From." reply-to)
221 (const :tag "Date less than four days old." date)
222 (const :tag "To and/or Cc longer than 1024 characters." long-to)
223 (const :tag "Multiple To and/or Cc headers." many-to))
224 :group 'gnus-article-hiding)
226 (defcustom gnus-article-skip-boring nil
227 "Skip over text that is not worth reading.
228 By default, if you set this t, then Gnus will display citations and
229 signatures, but will never scroll down to show you a page consisting
230 only of boring text. Boring text is controlled by
231 `gnus-article-boring-faces'."
234 :group 'gnus-article-hiding)
236 (defcustom gnus-signature-separator '("^-- $" "^-- *$")
237 "Regexp matching signature separator.
238 This can also be a list of regexps. In that case, it will be checked
239 from head to tail looking for a separator. Searches will be done from
240 the end of the buffer."
241 :type '(choice :format "%{%t%}: %[Value Menu%]\n%v"
243 (repeat :tag "List of regexp" regexp))
244 :group 'gnus-article-signature)
246 (defcustom gnus-signature-limit nil
247 "Provide a limit to what is considered a signature.
248 If it is a number, no signature may not be longer (in characters) than
249 that number. If it is a floating point number, no signature may be
250 longer (in lines) than that number. If it is a function, the function
251 will be called without any parameters, and if it returns nil, there is
252 no signature in the buffer. If it is a string, it will be used as a
253 regexp. If it matches, the text in question is not a signature.
255 This can also be a list of the above values."
256 :type '(choice (const nil)
260 (regexp :value ".*"))
261 :group 'gnus-article-signature)
263 (defcustom gnus-hidden-properties '(invisible t intangible t)
264 "Property list to use for hiding text."
266 :group 'gnus-article-hiding)
268 ;; Fixme: This isn't the right thing for mixed graphical and non-graphical
269 ;; frames in a session.
270 (defcustom gnus-article-x-face-command
271 (if (featurep 'xemacs)
272 (if (or (gnus-image-type-available-p 'xface)
273 (gnus-image-type-available-p 'pbm))
274 'gnus-display-x-face-in-from
275 "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | ee -")
276 (if (gnus-image-type-available-p 'pbm)
277 'gnus-display-x-face-in-from
278 "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | \
280 "*String or function to be executed to display an X-Face header.
281 If it is a string, the command will be executed in a sub-shell
282 asynchronously. The compressed face will be piped to this command."
283 :type `(choice string
284 (function-item gnus-display-x-face-in-from)
288 :group 'gnus-article-washing)
290 (defcustom gnus-article-x-face-too-ugly nil
291 "Regexp matching posters whose face shouldn't be shown automatically."
292 :type '(choice regexp (const nil))
293 :group 'gnus-article-washing)
295 (defcustom gnus-article-banner-alist nil
296 "Banner alist for stripping.
298 ((egroups . \"^[ \\t\\n]*-------------------+\\\\( \\\\(e\\\\|Yahoo! \\\\)Groups Sponsor -+\\\\)?....\\n\\\\(.+\\n\\\\)+\"))"
300 :type '(repeat (cons symbol regexp))
301 :group 'gnus-article-washing)
303 (gnus-define-group-parameter
306 "Alist of regexps (to match group names) and banner."
307 :variable-group gnus-article-washing
309 '(choice :tag "Banner"
311 (const :tag "Remove signature" signature)
312 (symbol :tag "Item in `gnus-article-banner-alist'" none)
314 (const :tag "None" nil))
316 "If non-nil, specify how to remove `banners' from articles.
318 Symbol `signature' means to remove signatures delimited by
319 `gnus-signature-separator'. Any other symbol is used to look up a
320 regular expression to match the banner in `gnus-article-banner-alist'.
321 A string is used as a regular expression to match the banner
324 (defcustom gnus-article-address-banner-alist nil
325 "Alist of mail addresses and banners.
326 Each element has the form (ADDRESS . BANNER), where ADDRESS is a regexp
327 to match a mail address in the From: header, BANNER is one of a symbol
328 `signature', an item in `gnus-article-banner-alist', a regexp and nil.
329 If ADDRESS matches author's mail address, it will remove things like
330 advertisements. For example:
332 \((\"@yoo-hoo\\\\.co\\\\.jp\\\\'\" . \"\\n_+\\nDo You Yoo-hoo!\\\\?\\n.*\\n.*\\n\"))
336 (regexp :tag "Address")
337 (choice :tag "Banner" :value nil
338 (const :tag "Remove signature" signature)
339 (symbol :tag "Item in `gnus-article-banner-alist'" none)
341 (const :tag "None" nil))))
343 :group 'gnus-article-washing)
345 (defmacro gnus-emphasis-custom-with-format (&rest body)
347 \\(\\s-\\|^\\|\\=\\|[-\"]\\|\\s(\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\
348 \\(\\([-,.;:!?\"]\\|\\s)\\)+\\s-\\|[?!.]\\s-\\|\\s)\\|\\s-\\)"))
351 (defun gnus-emphasis-custom-value-to-external (value)
352 (gnus-emphasis-custom-with-format
353 (if (consp (car value))
354 (list (format format (car (car value)) (cdr (car value)))
356 (if (nth 1 value) 2 3)
360 (defun gnus-emphasis-custom-value-to-internal (value)
361 (gnus-emphasis-custom-with-format
362 (let ((regexp (concat "\\`"
363 (format (regexp-quote format)
364 "\\([^()]+\\)" "\\([^()]+\\)")
367 (if (string-match regexp (setq pattern (car value)))
368 (list (cons (match-string 1 pattern) (match-string 2 pattern))
373 (defcustom gnus-emphasis-alist
375 '(("\\*" "\\*" bold nil 2)
378 ("_/" "/_" underline-italic)
379 ("_\\*" "\\*_" underline-bold)
380 ("\\*/" "/\\*" bold-italic)
381 ("_\\*/" "/\\*_" underline-bold-italic))))
383 (gnus-emphasis-custom-with-format
384 (mapcar (lambda (spec)
385 (list (format format (car spec) (cadr spec))
388 (intern (format "gnus-emphasis-%s" (nth 2 spec)))))
390 '(;; I've never seen anyone use this strikethru convention whereas I've
391 ;; several times seen it triggered by normal text. --Stef
392 ;; Miles suggests that this form is sometimes used but for italics,
393 ;; so maybe we should map it to `italic'.
394 ;; ("\\(\\s-\\|^\\)\\(-\\(\\(\\w\\|-[^-]\\)+\\)-\\)\\(\\s-\\|[?!.,;]\\)"
395 ;; 2 3 gnus-emphasis-strikethru)
396 ("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)"
397 2 3 gnus-emphasis-underline))))
398 "*Alist that says how to fontify certain phrases.
399 Each item looks like this:
401 (\"_\\\\(\\\\w+\\\\)_\" 0 1 'underline)
403 The first element is a regular expression to be matched. The second
404 is a number that says what regular expression grouping used to find
405 the entire emphasized word. The third is a number that says what
406 regexp grouping should be displayed and highlighted. The fourth
407 is the face used for highlighting."
411 :format "%[Customizing Style%]\n%v"
413 (group :tag "Default"
414 :value ("" 0 0 default)
417 (let ((value (widget-get
418 (cadr (widget-get (widget-get widget :parent)
421 (if (not (eq (nth 2 value) 'default))
425 (gnus-emphasis-custom-value-to-external value))))
426 (widget-group-value-create widget))
428 (integer :format "Match group: %v")
429 (integer :format "Emphasize group: %v")
432 :value (("_" . "_") nil default)
434 (regexp :format "Start regexp: %v")
435 (regexp :format "End regexp: %v"))
436 (boolean :format "Show start and end patterns: %[%v%]\n"
437 :on " On " :off " Off ")
439 :get (lambda (symbol)
440 (mapcar 'gnus-emphasis-custom-value-to-internal
441 (default-value symbol)))
442 :set (lambda (symbol value)
443 (set-default symbol (mapcar 'gnus-emphasis-custom-value-to-external
445 :group 'gnus-article-emphasis)
447 (defcustom gnus-emphasize-whitespace-regexp "^[ \t]+\\|[ \t]*\n"
448 "A regexp to describe whitespace which should not be emphasized.
449 Typical values are \"^[ \\t]+\\\\|[ \\t]*\\n\" and \"[ \\t]+\\\\|[ \\t]*\\n\".
450 The former avoids underlining of leading and trailing whitespace,
451 and the latter avoids underlining any whitespace at all."
453 :group 'gnus-article-emphasis
456 (defface gnus-emphasis-bold '((t (:bold t)))
457 "Face used for displaying strong emphasized text (*word*)."
458 :group 'gnus-article-emphasis)
460 (defface gnus-emphasis-italic '((t (:italic t)))
461 "Face used for displaying italic emphasized text (/word/)."
462 :group 'gnus-article-emphasis)
464 (defface gnus-emphasis-underline '((t (:underline t)))
465 "Face used for displaying underlined emphasized text (_word_)."
466 :group 'gnus-article-emphasis)
468 (defface gnus-emphasis-underline-bold '((t (:bold t :underline t)))
469 "Face used for displaying underlined bold emphasized text (_*word*_)."
470 :group 'gnus-article-emphasis)
472 (defface gnus-emphasis-underline-italic '((t (:italic t :underline t)))
473 "Face used for displaying underlined italic emphasized text (_/word/_)."
474 :group 'gnus-article-emphasis)
476 (defface gnus-emphasis-bold-italic '((t (:bold t :italic t)))
477 "Face used for displaying bold italic emphasized text (/*word*/)."
478 :group 'gnus-article-emphasis)
480 (defface gnus-emphasis-underline-bold-italic
481 '((t (:bold t :italic t :underline t)))
482 "Face used for displaying underlined bold italic emphasized text.
483 Example: (_/*word*/_)."
484 :group 'gnus-article-emphasis)
486 (defface gnus-emphasis-strikethru (if (featurep 'xemacs)
487 '((t (:strikethru t)))
488 '((t (:strike-through t))))
489 "Face used for displaying strike-through text (-word-)."
490 :group 'gnus-article-emphasis)
492 (defface gnus-emphasis-highlight-words
493 '((t (:background "black" :foreground "yellow")))
494 "Face used for displaying highlighted words."
495 :group 'gnus-article-emphasis)
497 (defcustom gnus-article-time-format "%a, %d %b %Y %T %Z"
498 "Format for display of Date headers in article bodies.
499 See `format-time-string' for the possible values.
501 The variable can also be function, which should return a complete Date
502 header. The function is called with one argument, the time, which can
503 be fed to `format-time-string'."
504 :type '(choice string function)
505 :link '(custom-manual "(gnus)Article Date")
506 :group 'gnus-article-washing)
508 (defcustom gnus-save-all-headers t
509 "*If non-nil, don't remove any headers before saving.
510 This will be overridden by the `:headers' property that the symbol of
511 the saver function, which is specified by `gnus-default-article-saver',
513 :group 'gnus-article-saving
516 (defcustom gnus-prompt-before-saving 'always
517 "*This variable says how much prompting is to be done when saving articles.
518 If it is nil, no prompting will be done, and the articles will be
519 saved to the default files. If this variable is `always', each and
520 every article that is saved will be preceded by a prompt, even when
521 saving large batches of articles. If this variable is neither nil not
522 `always', there the user will be prompted once for a file name for
523 each invocation of the saving commands."
524 :group 'gnus-article-saving
525 :type '(choice (item always)
526 (item :tag "never" nil)
527 (sexp :tag "once" :format "%t\n" :value t)))
529 (defcustom gnus-saved-headers gnus-visible-headers
530 "Headers to keep if `gnus-save-all-headers' is nil.
531 If `gnus-save-all-headers' is non-nil, this variable will be ignored.
532 If that variable is nil, however, all headers that match this regexp
533 will be kept while the rest will be deleted before saving. This and
534 `gnus-save-all-headers' will be overridden by the `:headers' property
535 that the symbol of the saver function, which is specified by
536 `gnus-default-article-saver', might have."
537 :group 'gnus-article-saving
540 (defcustom gnus-default-article-saver 'gnus-summary-save-in-rmail
541 "A function to save articles in your favourite format.
542 The function will be called by way of the `gnus-summary-save-article'
543 command, and friends such as `gnus-summary-save-article-rmail'.
545 Gnus provides the following functions:
547 * gnus-summary-save-in-rmail (Rmail format)
548 * gnus-summary-save-in-mail (Unix mail format)
549 * gnus-summary-save-in-folder (MH folder)
550 * gnus-summary-save-in-file (article format)
551 * gnus-summary-save-body-in-file (article body)
552 * gnus-summary-save-in-vm (use VM's folder format)
553 * gnus-summary-write-to-file (article format -- overwrite)
554 * gnus-summary-write-body-to-file (article body -- overwrite)
555 * gnus-summary-save-in-pipe (article format)
557 The symbol of each function may have the following properties:
560 The value non-nil means save decoded articles. This is meaningful
561 only with `gnus-summary-save-in-file', `gnus-summary-save-body-in-file',
562 `gnus-summary-write-to-file', `gnus-summary-write-body-to-file', and
563 `gnus-summary-save-in-pipe'.
566 The value specifies an alternative function which appends, not
567 overwrites, articles to a file. This implies that when saving many
568 articles at a time, `gnus-prompt-before-saving' is bound to t and all
569 articles are saved in a single file. This is meaningful only with
570 `gnus-summary-write-to-file' and `gnus-summary-write-body-to-file'.
573 The value specifies the symbol of a variable of which the value
574 specifies headers to be saved. If it is omitted,
575 `gnus-save-all-headers' and `gnus-saved-headers' control what
576 headers should be saved."
577 :group 'gnus-article-saving
578 :type '(radio (function-item gnus-summary-save-in-rmail)
579 (function-item gnus-summary-save-in-mail)
580 (function-item gnus-summary-save-in-folder)
581 (function-item gnus-summary-save-in-file)
582 (function-item gnus-summary-save-body-in-file)
583 (function-item gnus-summary-save-in-vm)
584 (function-item gnus-summary-write-to-file)
585 (function-item gnus-summary-write-body-to-file)
586 (function-item gnus-summary-save-in-pipe)
589 (defcustom gnus-article-save-coding-system
590 (or (and (mm-coding-system-p 'utf-8) 'utf-8)
591 (and (mm-coding-system-p 'iso-2022-7bit) 'iso-2022-7bit)
592 (and (mm-coding-system-p 'emacs-mule) 'emacs-mule)
593 (and (mm-coding-system-p 'escape-quoted) 'escape-quoted))
594 "Coding system used to save decoded articles to a file.
596 The recommended coding systems are `utf-8', `iso-2022-7bit' and so on,
597 which can safely encode any characters in text. This is used by the
600 * gnus-summary-save-article-file
601 * gnus-summary-save-article-body-file
602 * gnus-summary-write-article-file
603 * gnus-summary-write-article-body-file
605 and the functions to which you may set `gnus-default-article-saver':
607 * gnus-summary-save-in-file
608 * gnus-summary-save-body-in-file
609 * gnus-summary-write-to-file
610 * gnus-summary-write-body-to-file
612 Those commands and functions save just text displayed in the article
613 buffer to a file if the value of this variable is non-nil. Note that
614 buttonized MIME parts will be lost in a saved file in that case.
615 Otherwise, raw articles will be saved."
616 :group 'gnus-article-saving
618 :format "%{%t%}:\n %[Value Menu%] %v"
619 (const :tag "Save raw articles" nil)
622 (lambda (arg) (if (mm-coding-system-p (nth 3 arg)) arg))
623 '((const :tag "UTF-8" utf-8)
624 (const :tag "iso-2022-7bit" iso-2022-7bit)
625 (const :tag "Emacs internal" emacs-mule)
626 (const :tag "escape-quoted" escape-quoted))))
627 (symbol :tag "Coding system")))
629 (defcustom gnus-rmail-save-name 'gnus-plain-save-name
630 "A function generating a file name to save articles in Rmail format.
631 The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE."
632 :group 'gnus-article-saving
635 (defcustom gnus-mail-save-name 'gnus-plain-save-name
636 "A function generating a file name to save articles in Unix mail format.
637 The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE."
638 :group 'gnus-article-saving
641 (defcustom gnus-folder-save-name 'gnus-folder-save-name
642 "A function generating a file name to save articles in MH folder.
643 The function is called with NEWSGROUP, HEADERS, and optional LAST-FOLDER."
644 :group 'gnus-article-saving
647 (defcustom gnus-file-save-name 'gnus-numeric-save-name
648 "A function generating a file name to save articles in article format.
649 The function is called with NEWSGROUP, HEADERS, and optional
651 :group 'gnus-article-saving
654 (defcustom gnus-split-methods
655 '((gnus-article-archive-name)
656 (gnus-article-nndoc-name))
657 "*Variable used to suggest where articles are to be saved.
658 For instance, if you would like to save articles related to Gnus in
659 the file \"gnus-stuff\", and articles related to VM in \"vm-stuff\",
660 you could set this variable to something like:
662 '((\"^Subject:.*gnus\\|^Newsgroups:.*gnus\" \"gnus-stuff\")
663 (\"^Subject:.*vm\\|^Xref:.*vm\" \"vm-stuff\"))
665 This variable is an alist where the key is the match and the
666 value is a list of possible files to save in if the match is
669 If the match is a string, it is used as a regexp match on the
670 article. If the match is a symbol, that symbol will be funcalled
671 from the buffer of the article to be saved with the newsgroup as the
672 parameter. If it is a list, it will be evaled in the same buffer.
674 If this form or function returns a string, this string will be used as a
675 possible file name; and if it returns a non-nil list, that list will be
676 used as possible file names."
677 :group 'gnus-article-saving
678 :type '(repeat (choice (list :value (fun) function)
679 (cons :value ("" "") regexp (repeat string))
682 (defcustom gnus-page-delimiter "^\^L"
683 "*Regexp describing what to use as article page delimiters.
684 The default value is \"^\^L\", which is a form linefeed at the
685 beginning of a line."
687 :group 'gnus-article-various)
689 (defcustom gnus-article-mode-line-format "Gnus: %g [%w] %S%m"
690 "*The format specification for the article mode line.
691 See `gnus-summary-mode-line-format' for a closer description.
693 The following additional specs are available:
695 %w The article washing status.
696 %m The number of MIME parts in the article."
698 :group 'gnus-article-various)
700 (defcustom gnus-article-mode-hook nil
701 "*A hook for Gnus article mode."
703 :group 'gnus-article-various)
705 (when (featurep 'xemacs)
706 ;; Extracted from gnus-xmas-define in order to preserve user settings
707 (when (fboundp 'turn-off-scroll-in-place)
708 (add-hook 'gnus-article-mode-hook 'turn-off-scroll-in-place))
709 ;; Extracted from gnus-xmas-redefine in order to preserve user settings
710 (add-hook 'gnus-article-mode-hook 'gnus-xmas-article-menu-add))
712 (defcustom gnus-article-menu-hook nil
713 "*Hook run after the creation of the article mode menu."
715 :group 'gnus-article-various)
717 (defcustom gnus-article-prepare-hook nil
718 "*A hook called after an article has been prepared in the article buffer."
720 :group 'gnus-article-various)
722 (defcustom gnus-copy-article-ignored-headers nil
723 "List of headers to be removed when copying an article.
724 Each element is a regular expression."
725 :version "23.1" ;; No Gnus
726 :type '(repeat regexp)
727 :group 'gnus-article-various)
729 (make-obsolete-variable 'gnus-article-hide-pgp-hook
730 "This variable is obsolete in Gnus 5.10.")
733 '((t (:weight bold)))
734 "Face used for highlighting a button in the article buffer."
735 :group 'gnus-article-buttons)
737 (defcustom gnus-article-button-face 'gnus-button
738 "Face used for highlighting buttons in the article buffer.
740 An article button is a piece of text that you can activate by pressing
741 `RET' or `mouse-2' above it."
743 :group 'gnus-article-buttons)
745 (defcustom gnus-article-mouse-face 'highlight
746 "Face used for mouse highlighting in the article buffer.
748 Article buttons will be displayed in this face when the cursor is
751 :group 'gnus-article-buttons)
753 (defcustom gnus-signature-face 'gnus-signature
754 "Face used for highlighting a signature in the article buffer.
755 Obsolete; use the face `gnus-signature' for customizations instead."
757 :group 'gnus-article-highlight
758 :group 'gnus-article-signature)
760 (defface gnus-signature
763 "Face used for highlighting a signature in the article buffer."
764 :group 'gnus-article-highlight
765 :group 'gnus-article-signature)
766 ;; backward-compatibility alias
767 (put 'gnus-signature-face 'face-alias 'gnus-signature)
769 (defface gnus-header-from
772 (:foreground "PaleGreen1"))
775 (:foreground "red3"))
778 "Face used for displaying from headers."
779 :group 'gnus-article-headers
780 :group 'gnus-article-highlight)
781 ;; backward-compatibility alias
782 (put 'gnus-header-from-face 'face-alias 'gnus-header-from)
784 (defface gnus-header-subject
787 (:foreground "SeaGreen1"))
790 (:foreground "red4"))
792 (:bold t :italic t)))
793 "Face used for displaying subject headers."
794 :group 'gnus-article-headers
795 :group 'gnus-article-highlight)
796 ;; backward-compatibility alias
797 (put 'gnus-header-subject-face 'face-alias 'gnus-header-subject)
799 (defface gnus-header-newsgroups
802 (:foreground "yellow" :italic t))
805 (:foreground "MidnightBlue" :italic t))
808 "Face used for displaying newsgroups headers.
809 In the default setup this face is only used for crossposted
811 :group 'gnus-article-headers
812 :group 'gnus-article-highlight)
813 ;; backward-compatibility alias
814 (put 'gnus-header-newsgroups-face 'face-alias 'gnus-header-newsgroups)
816 (defface gnus-header-name
819 (:foreground "SpringGreen2"))
822 (:foreground "maroon"))
825 "Face used for displaying header names."
826 :group 'gnus-article-headers
827 :group 'gnus-article-highlight)
828 ;; backward-compatibility alias
829 (put 'gnus-header-name-face 'face-alias 'gnus-header-name)
831 (defface gnus-header-content
834 (:foreground "SpringGreen1" :italic t))
837 (:foreground "indianred4" :italic t))
839 (:italic t))) "Face used for displaying header content."
840 :group 'gnus-article-headers
841 :group 'gnus-article-highlight)
842 ;; backward-compatibility alias
843 (put 'gnus-header-content-face 'face-alias 'gnus-header-content)
845 (defcustom gnus-header-face-alist
846 '(("From" nil gnus-header-from)
847 ("Subject" nil gnus-header-subject)
848 ("Newsgroups:.*," nil gnus-header-newsgroups)
849 ("" gnus-header-name gnus-header-content))
850 "*Controls highlighting of article headers.
852 An alist of the form (HEADER NAME CONTENT).
854 HEADER is a regular expression which should match the name of a
855 header and NAME and CONTENT are either face names or nil.
857 The name of each header field will be displayed using the face
858 specified by the first element in the list where HEADER matches
859 the header name and NAME is non-nil. Similarly, the content will
860 be displayed by the first non-nil matching CONTENT face."
861 :group 'gnus-article-headers
862 :group 'gnus-article-highlight
863 :type '(repeat (list (regexp :tag "Header")
865 (item :tag "skip" nil)
866 (face :value default))
867 (choice :tag "Content"
868 (item :tag "skip" nil)
869 (face :value default)))))
871 (defcustom gnus-face-properties-alist (if (featurep 'xemacs)
872 '((xface . (:face gnus-x-face)))
873 '((pbm . (:face gnus-x-face))
875 "Alist of image types and properties applied to Face and X-Face images.
878 ;; Specify the altitude of Face images in the From header.
879 \(setq gnus-face-properties-alist
880 '((pbm . (:face gnus-x-face :ascent 80))
881 (png . (:ascent 80))))
883 ;; Show Face images as pressed buttons.
884 \(setq gnus-face-properties-alist
885 '((pbm . (:face gnus-x-face :relief -2))
886 (png . (:relief -2))))
888 See the manual for the valid properties for various image types.
889 Currently, `pbm' is used for X-Face images and `png' is used for Face
890 images in Emacs. Only the `:face' property is effective on the `xface'
891 image type in XEmacs if it is built with the libcompface library."
892 :version "23.1" ;; No Gnus
893 :group 'gnus-article-headers
894 :type '(repeat (cons :format "%v" (symbol :tag "Image type") plist)))
896 (defcustom gnus-article-decode-hook
897 '(article-decode-charset article-decode-encoded-words
898 article-decode-group-name article-decode-idna-rhs)
899 "*Hook run to decode charsets in articles."
900 :group 'gnus-article-headers
903 (defcustom gnus-display-mime-function 'gnus-display-mime
904 "Function to display MIME articles."
905 :group 'gnus-article-mime
908 (defvar gnus-decode-header-function 'mail-decode-encoded-word-region
909 "Function used to decode headers.")
911 (defvar gnus-decode-address-function 'mail-decode-encoded-address-region
912 "Function used to decode addresses.")
914 (defvar gnus-article-dumbquotes-map
934 "Table for MS-to-Latin1 translation.")
936 (defcustom gnus-ignored-mime-types nil
937 "List of MIME types that should be ignored by Gnus."
939 :group 'gnus-article-mime
940 :type '(repeat regexp))
942 (defcustom gnus-unbuttonized-mime-types '(".*/.*")
943 "List of MIME types that should not be given buttons when rendered inline.
944 See also `gnus-buttonized-mime-types' which may override this variable.
945 This variable is only used when `gnus-inhibit-mime-unbuttonizing' is nil."
947 :group 'gnus-article-mime
948 :type '(repeat regexp))
950 (defcustom gnus-buttonized-mime-types nil
951 "List of MIME types that should be given buttons when rendered inline.
952 If set, this variable overrides `gnus-unbuttonized-mime-types'.
953 To see e.g. security buttons you could set this to
954 `(\"multipart/signed\")'. You could also add \"multipart/alternative\" to
955 this list to display radio buttons that allow you to choose one of two
956 media types those mails include. See also `mm-discouraged-alternatives'.
957 This variable is only used when `gnus-inhibit-mime-unbuttonizing' is nil."
959 :group 'gnus-article-mime
960 :type '(repeat regexp))
962 (defcustom gnus-inhibit-mime-unbuttonizing nil
963 "If non-nil, all MIME parts get buttons.
964 When nil (the default value), then some MIME parts do not get buttons,
965 as described by the variables `gnus-buttonized-mime-types' and
966 `gnus-unbuttonized-mime-types'."
968 :group 'gnus-article-mime
971 (defcustom gnus-body-boundary-delimiter "_"
972 "String used to delimit header and body.
973 This variable is used by `gnus-article-treat-body-boundary' which can
974 be controlled by `gnus-treat-body-boundary'."
976 :group 'gnus-article-various
977 :type '(choice (item :tag "None" :value nil)
980 (defcustom gnus-picon-databases '("/usr/lib/picon" "/usr/local/faces"
982 "Defines the location of the faces database.
983 For information on obtaining this database of pretty pictures, please
984 see http://www.cs.indiana.edu/picons/ftp/index.html"
986 :type '(repeat directory)
987 :link '(url-link :tag "download"
988 "http://www.cs.indiana.edu/picons/ftp/index.html")
989 :link '(custom-manual "(gnus)Picons")
992 (defun gnus-picons-installed-p ()
993 "Say whether picons are installed on your machine."
994 (let ((installed nil))
995 (dolist (database gnus-picon-databases)
996 (when (file-exists-p database)
1000 (defcustom gnus-article-mime-part-function nil
1001 "Function called with a MIME handle as the argument.
1002 This is meant for people who want to do something automatic based
1003 on parts -- for instance, adding Vcard info to a database."
1004 :group 'gnus-article-mime
1005 :type '(choice (const nil)
1008 (defcustom gnus-mime-multipart-functions nil
1009 "An alist of MIME types to functions to display them."
1011 :group 'gnus-article-mime
1012 :type '(repeat (cons :format "%v" (string :tag "MIME type") function)))
1014 (defcustom gnus-article-date-lapsed-new-header nil
1015 "Whether the X-Sent and Date headers can coexist.
1016 When using `gnus-treat-date-lapsed', the \"X-Sent:\" header will
1017 either replace the old \"Date:\" header (if this variable is nil), or
1018 be added below it (otherwise)."
1020 :group 'gnus-article-headers
1023 (defcustom gnus-article-mime-match-handle-function 'undisplayed-alternative
1024 "Function called with a MIME handle as the argument.
1025 This is meant for people who want to view first matched part.
1026 For `undisplayed-alternative' (default), the first undisplayed
1027 part or alternative part is used. For `undisplayed', the first
1028 undisplayed part is used. For a function, the first part which
1029 the function return t is used. For nil, the first part is
1032 :group 'gnus-article-mime
1034 (item :tag "first" :value nil)
1035 (item :tag "undisplayed" :value undisplayed)
1036 (item :tag "undisplayed or alternative"
1037 :value undisplayed-alternative)
1040 (defcustom gnus-mime-action-alist
1041 '(("save to file" . gnus-mime-save-part)
1042 ("save and strip" . gnus-mime-save-part-and-strip)
1043 ("replace with file" . gnus-mime-replace-part)
1044 ("delete part" . gnus-mime-delete-part)
1045 ("display as text" . gnus-mime-inline-part)
1046 ("view the part" . gnus-mime-view-part)
1047 ("pipe to command" . gnus-mime-pipe-part)
1048 ("toggle display" . gnus-article-press-button)
1049 ("toggle display" . gnus-article-view-part-as-charset)
1050 ("view as type" . gnus-mime-view-part-as-type)
1051 ("view internally" . gnus-mime-view-part-internally)
1052 ("view externally" . gnus-mime-view-part-externally))
1053 "An alist of actions that run on the MIME attachment."
1054 :group 'gnus-article-mime
1055 :type '(repeat (cons (string :tag "name")
1058 (defcustom gnus-auto-select-part 1
1059 "Advance to next MIME part when deleting or stripping parts.
1061 When 0, point will be placed on the same part as before. When
1062 positive (negative), move point forward (backwards) this many
1063 parts. When nil, redisplay article."
1064 :version "23.1" ;; No Gnus
1065 :group 'gnus-article-mime
1066 :type '(choice (const nil :tag "Redisplay article.")
1067 (const 1 :tag "Next part.")
1068 (const 0 :tag "Current part.")
1072 ;;; The treatment variables
1075 (defvar gnus-part-display-hook nil
1076 "Hook called on parts that are to receive treatment.")
1078 (defvar gnus-article-treat-custom
1079 '(choice (const :tag "Off" nil)
1081 (const :tag "Header" head)
1082 (const :tag "First" first)
1083 (const :tag "Last" last)
1084 (integer :tag "Less")
1085 (repeat :tag "Groups" regexp)
1086 (sexp :tag "Predicate")))
1088 (defvar gnus-article-treat-head-custom
1089 '(choice (const :tag "Off" nil)
1090 (const :tag "Header" head)))
1092 (defvar gnus-article-treat-types '("text/plain" "text/x-verbatim"
1096 (defvar gnus-inhibit-treatment nil
1097 "Whether to inhibit treatment.")
1099 (defcustom gnus-treat-highlight-signature '(or t (typep "text/x-vcard"))
1100 "Highlight the signature.
1101 Valid values are nil, t, `head', `first', `last', an integer or a
1102 predicate. See Info node `(gnus)Customizing Articles'."
1103 :group 'gnus-article-treat
1104 :link '(custom-manual "(gnus)Customizing Articles")
1105 :type gnus-article-treat-custom)
1106 (put 'gnus-treat-highlight-signature 'highlight t)
1108 (defcustom gnus-treat-buttonize 100000
1110 Valid values are nil, t, `head', `first', `last', an integer or a
1111 predicate. See Info node `(gnus)Customizing Articles'."
1112 :group 'gnus-article-treat
1113 :link '(custom-manual "(gnus)Customizing Articles")
1114 :type gnus-article-treat-custom)
1115 (put 'gnus-treat-buttonize 'highlight t)
1117 (defcustom gnus-treat-buttonize-head 'head
1118 "Add buttons to the head.
1119 Valid values are nil, t, `head', `first', `last', an integer or a
1120 predicate. See Info node `(gnus)Customizing Articles'."
1121 :group 'gnus-article-treat
1122 :link '(custom-manual "(gnus)Customizing Articles")
1123 :type gnus-article-treat-head-custom)
1124 (put 'gnus-treat-buttonize-head 'highlight t)
1126 (defcustom gnus-treat-emphasize 50000
1128 Valid values are nil, t, `head', `first', `last', an integer or a
1129 predicate. See Info node `(gnus)Customizing Articles'."
1130 :group 'gnus-article-treat
1131 :link '(custom-manual "(gnus)Customizing Articles")
1132 :type gnus-article-treat-custom)
1133 (put 'gnus-treat-emphasize 'highlight t)
1135 (defcustom gnus-treat-strip-cr nil
1136 "Remove carriage returns.
1137 Valid values are nil, t, `head', `first', `last', an integer or a
1138 predicate. See Info node `(gnus)Customizing Articles'."
1140 :group 'gnus-article-treat
1141 :link '(custom-manual "(gnus)Customizing Articles")
1142 :type gnus-article-treat-custom)
1144 (defcustom gnus-treat-unsplit-urls nil
1145 "Remove newlines from within URLs.
1146 Valid values are nil, t, `head', `first', `last', an integer or a
1147 predicate. See Info node `(gnus)Customizing Articles'."
1149 :group 'gnus-article-treat
1150 :link '(custom-manual "(gnus)Customizing Articles")
1151 :type gnus-article-treat-custom)
1153 (defcustom gnus-treat-leading-whitespace nil
1154 "Remove leading whitespace in headers.
1155 Valid values are nil, t, `head', `first', `last', an integer or a
1156 predicate. See Info node `(gnus)Customizing Articles'."
1158 :group 'gnus-article-treat
1159 :link '(custom-manual "(gnus)Customizing Articles")
1160 :type gnus-article-treat-custom)
1162 (defcustom gnus-treat-hide-headers 'head
1164 Valid values are nil, t, `head', `first', `last', an integer or a
1165 predicate. See Info node `(gnus)Customizing Articles'."
1166 :group 'gnus-article-treat
1167 :link '(custom-manual "(gnus)Customizing Articles")
1168 :type gnus-article-treat-head-custom)
1170 (defcustom gnus-treat-hide-boring-headers nil
1171 "Hide boring headers.
1172 Valid values are nil, t, `head', `first', `last', an integer or a
1173 predicate. See Info node `(gnus)Customizing Articles'."
1174 :group 'gnus-article-treat
1175 :link '(custom-manual "(gnus)Customizing Articles")
1176 :type gnus-article-treat-head-custom)
1178 (defcustom gnus-treat-hide-signature nil
1179 "Hide the signature.
1180 Valid values are nil, t, `head', `first', `last', an integer or a
1181 predicate. See Info node `(gnus)Customizing Articles'."
1182 :group 'gnus-article-treat
1183 :link '(custom-manual "(gnus)Customizing Articles")
1184 :type gnus-article-treat-custom)
1186 (defcustom gnus-treat-fill-article nil
1188 Valid values are nil, t, `head', `first', `last', an integer or a
1189 predicate. See Info node `(gnus)Customizing Articles'."
1190 :group 'gnus-article-treat
1191 :link '(custom-manual "(gnus)Customizing Articles")
1192 :type gnus-article-treat-custom)
1194 (defcustom gnus-treat-hide-citation nil
1196 Valid values are nil, t, `head', `first', `last', an integer or a
1197 predicate. See Info node `(gnus)Customizing Articles'."
1198 :group 'gnus-article-treat
1199 :link '(custom-manual "(gnus)Customizing Articles")
1200 :type gnus-article-treat-custom)
1202 (defcustom gnus-treat-hide-citation-maybe nil
1204 Valid values are nil, t, `head', `first', `last', an integer or a
1205 predicate. See Info node `(gnus)Customizing Articles'."
1206 :group 'gnus-article-treat
1207 :link '(custom-manual "(gnus)Customizing Articles")
1208 :type gnus-article-treat-custom)
1210 (defcustom gnus-treat-strip-list-identifiers 'head
1211 "Strip list identifiers from `gnus-list-identifiers`.
1212 Valid values are nil, t, `head', `first', `last', an integer or a
1213 predicate. See Info node `(gnus)Customizing Articles'."
1215 :group 'gnus-article-treat
1216 :link '(custom-manual "(gnus)Customizing Articles")
1217 :type gnus-article-treat-custom)
1219 (make-obsolete-variable 'gnus-treat-strip-pgp
1220 "This option is obsolete in Gnus 5.10.")
1222 (defcustom gnus-treat-strip-pem nil
1223 "Strip PEM signatures.
1224 Valid values are nil, t, `head', `first', `last', an integer or a
1225 predicate. See Info node `(gnus)Customizing Articles'."
1226 :group 'gnus-article-treat
1227 :link '(custom-manual "(gnus)Customizing Articles")
1228 :type gnus-article-treat-custom)
1230 (defcustom gnus-treat-strip-banner t
1231 "Strip banners from articles.
1232 The banner to be stripped is specified in the `banner' group parameter.
1233 Valid values are nil, t, `head', `first', `last', an integer or a
1234 predicate. See Info node `(gnus)Customizing Articles'."
1235 :group 'gnus-article-treat
1236 :link '(custom-manual "(gnus)Customizing Articles")
1237 :type gnus-article-treat-custom)
1239 (defcustom gnus-treat-highlight-headers 'head
1240 "Highlight the headers.
1241 Valid values are nil, t, `head', `first', `last', an integer or a
1242 predicate. See Info node `(gnus)Customizing Articles'."
1243 :group 'gnus-article-treat
1244 :link '(custom-manual "(gnus)Customizing Articles")
1245 :type gnus-article-treat-head-custom)
1246 (put 'gnus-treat-highlight-headers 'highlight t)
1248 (defcustom gnus-treat-highlight-citation t
1249 "Highlight cited text.
1250 Valid values are nil, t, `head', `first', `last', an integer or a
1251 predicate. See Info node `(gnus)Customizing Articles'."
1252 :group 'gnus-article-treat
1253 :link '(custom-manual "(gnus)Customizing Articles")
1254 :type gnus-article-treat-custom)
1255 (put 'gnus-treat-highlight-citation 'highlight t)
1257 (defcustom gnus-treat-date-ut nil
1258 "Display the Date in UT (GMT).
1259 Valid values are nil, t, `head', `first', `last', an integer or a
1260 predicate. See Info node `(gnus)Customizing Articles'."
1261 :group 'gnus-article-treat
1262 :link '(custom-manual "(gnus)Customizing Articles")
1263 :type gnus-article-treat-head-custom)
1265 (defcustom gnus-treat-date-local nil
1266 "Display the Date in the local timezone.
1267 Valid values are nil, t, `head', `first', `last', an integer or a
1268 predicate. See Info node `(gnus)Customizing Articles'."
1269 :group 'gnus-article-treat
1270 :link '(custom-manual "(gnus)Customizing Articles")
1271 :type gnus-article-treat-head-custom)
1273 (defcustom gnus-treat-date-english nil
1274 "Display the Date in a format that can be read aloud in English.
1275 Valid values are nil, t, `head', `first', `last', an integer or a
1276 predicate. See Info node `(gnus)Customizing Articles'."
1278 :group 'gnus-article-treat
1279 :link '(custom-manual "(gnus)Customizing Articles")
1280 :type gnus-article-treat-head-custom)
1282 (defcustom gnus-treat-date-lapsed nil
1283 "Display the Date header in a way that says how much time has elapsed.
1284 Valid values are nil, t, `head', `first', `last', an integer or a
1285 predicate. See Info node `(gnus)Customizing Articles'."
1286 :group 'gnus-article-treat
1287 :link '(custom-manual "(gnus)Customizing Articles")
1288 :type gnus-article-treat-head-custom)
1290 (defcustom gnus-treat-date-original nil
1291 "Display the date in the original timezone.
1292 Valid values are nil, t, `head', `first', `last', an integer or a
1293 predicate. See Info node `(gnus)Customizing Articles'."
1294 :group 'gnus-article-treat
1295 :link '(custom-manual "(gnus)Customizing Articles")
1296 :type gnus-article-treat-head-custom)
1298 (defcustom gnus-treat-date-iso8601 nil
1299 "Display the date in the ISO8601 format.
1300 Valid values are nil, t, `head', `first', `last', an integer or a
1301 predicate. See Info node `(gnus)Customizing Articles'."
1303 :group 'gnus-article-treat
1304 :link '(custom-manual "(gnus)Customizing Articles")
1305 :type gnus-article-treat-head-custom)
1307 (defcustom gnus-treat-date-user-defined nil
1308 "Display the date in a user-defined format.
1309 The format is defined by the `gnus-article-time-format' variable.
1310 Valid values are nil, t, `head', `first', `last', an integer or a
1311 predicate. See Info node `(gnus)Customizing Articles'."
1312 :group 'gnus-article-treat
1313 :link '(custom-manual "(gnus)Customizing Articles")
1314 :type gnus-article-treat-head-custom)
1316 (defcustom gnus-treat-strip-headers-in-body t
1317 "Strip the X-No-Archive header line from the beginning of the body.
1318 Valid values are nil, t, `head', `first', `last', an integer or a
1319 predicate. See Info node `(gnus)Customizing Articles'."
1321 :group 'gnus-article-treat
1322 :link '(custom-manual "(gnus)Customizing Articles")
1323 :type gnus-article-treat-custom)
1325 (defcustom gnus-treat-strip-trailing-blank-lines nil
1326 "Strip trailing blank lines.
1327 Valid values are nil, t, `head', `first', `last', an integer or a
1328 predicate. See Info node `(gnus)Customizing Articles'.
1330 When set to t, it also strips trailing blanks in all MIME parts.
1331 Consider to use `last' instead."
1332 :group 'gnus-article-treat
1333 :link '(custom-manual "(gnus)Customizing Articles")
1334 :type gnus-article-treat-custom)
1336 (defcustom gnus-treat-strip-leading-blank-lines nil
1337 "Strip leading blank lines.
1338 Valid values are nil, t, `head', `first', `last', an integer or a
1339 predicate. See Info node `(gnus)Customizing Articles'.
1341 When set to t, it also strips trailing blanks in all MIME parts."
1342 :group 'gnus-article-treat
1343 :link '(custom-manual "(gnus)Customizing Articles")
1344 :type gnus-article-treat-custom)
1346 (defcustom gnus-treat-strip-multiple-blank-lines nil
1347 "Strip multiple blank lines.
1348 Valid values are nil, t, `head', `first', `last', an integer or a
1349 predicate. See Info node `(gnus)Customizing Articles'."
1350 :group 'gnus-article-treat
1351 :link '(custom-manual "(gnus)Customizing Articles")
1352 :type gnus-article-treat-custom)
1354 (defcustom gnus-treat-unfold-headers 'head
1355 "Unfold folded header lines.
1356 Valid values are nil, t, `head', `first', `last', an integer or a
1357 predicate. See Info node `(gnus)Customizing Articles'."
1359 :group 'gnus-article-treat
1360 :link '(custom-manual "(gnus)Customizing Articles")
1361 :type gnus-article-treat-custom)
1363 (defcustom gnus-article-unfold-long-headers nil
1364 "If non-nil, allow unfolding headers even if the header is long.
1365 If it is a regexp, only long headers matching this regexp are unfolded.
1366 If it is t, all long headers are unfolded.
1368 This variable has no effect if `gnus-treat-unfold-headers' is nil."
1369 :version "23.1" ;; No Gnus
1370 :group 'gnus-article-treat
1371 :type '(choice (const nil)
1372 (const :tag "all" t)
1375 (defcustom gnus-treat-fold-headers nil
1377 Valid values are nil, t, `head', `first', `last', an integer or a
1378 predicate. See Info node `(gnus)Customizing Articles'."
1380 :group 'gnus-article-treat
1381 :link '(custom-manual "(gnus)Customizing Articles")
1382 :type gnus-article-treat-custom)
1384 (defcustom gnus-treat-fold-newsgroups 'head
1385 "Fold the Newsgroups and Followup-To headers.
1386 Valid values are nil, t, `head', `first', `last', an integer or a
1387 predicate. See Info node `(gnus)Customizing Articles'."
1389 :group 'gnus-article-treat
1390 :link '(custom-manual "(gnus)Customizing Articles")
1391 :type gnus-article-treat-custom)
1393 (defcustom gnus-treat-overstrike t
1394 "Treat overstrike highlighting.
1395 Valid values are nil, t, `head', `first', `last', an integer or a
1396 predicate. See Info node `(gnus)Customizing Articles'."
1397 :group 'gnus-article-treat
1398 :link '(custom-manual "(gnus)Customizing Articles")
1399 :type gnus-article-treat-custom)
1400 (put 'gnus-treat-overstrike 'highlight t)
1402 (defcustom gnus-treat-ansi-sequences (if (locate-library "ansi-color") t)
1403 "Treat ANSI SGR control sequences.
1404 Valid values are nil, t, `head', `first', `last', an integer or a
1405 predicate. See Info node `(gnus)Customizing Articles'."
1406 :group 'gnus-article-treat
1407 :link '(custom-manual "(gnus)Customizing Articles")
1408 :type gnus-article-treat-custom)
1410 (make-obsolete-variable 'gnus-treat-display-xface
1411 'gnus-treat-display-x-face)
1413 (defcustom gnus-treat-display-x-face
1414 (and (not noninteractive)
1415 (gnus-image-type-available-p 'xbm)
1416 (if (featurep 'xemacs)
1418 (and (string-match "^0x" (shell-command-to-string "uncompface"))
1419 (executable-find "icontopbm")))
1421 "Display X-Face headers.
1422 Valid values are nil and `head'.
1423 See Info node `(gnus)Customizing Articles' and Info node
1424 `(gnus)X-Face' for details."
1425 :group 'gnus-article-treat
1427 :link '(custom-manual "(gnus)Customizing Articles")
1428 :link '(custom-manual "(gnus)X-Face")
1429 :type gnus-article-treat-head-custom
1430 :set (lambda (symbol value)
1433 (cond ((or (boundp symbol) (get symbol 'saved-value))
1435 ((boundp 'gnus-treat-display-xface)
1437 ** gnus-treat-display-xface is an obsolete variable;\
1438 use gnus-treat-display-x-face instead")
1439 (default-value 'gnus-treat-display-xface))
1440 ((get 'gnus-treat-display-xface 'saved-value)
1442 ** gnus-treat-display-xface is an obsolete variable;\
1443 use gnus-treat-display-x-face instead")
1444 (eval (car (get 'gnus-treat-display-xface 'saved-value))))
1447 (put 'gnus-treat-display-x-face 'highlight t)
1449 (defcustom gnus-treat-display-face
1450 (and (not noninteractive)
1451 (gnus-image-type-available-p 'png)
1453 "Display Face headers.
1454 Valid values are nil, t, `head', `first', `last', an integer or a
1455 predicate. See Info node `(gnus)Customizing Articles' and Info
1456 node `(gnus)X-Face' for details."
1457 :group 'gnus-article-treat
1459 :link '(custom-manual "(gnus)Customizing Articles")
1460 :link '(custom-manual "(gnus)X-Face")
1461 :type gnus-article-treat-head-custom)
1462 (put 'gnus-treat-display-face 'highlight t)
1464 (defcustom gnus-treat-display-smileys (gnus-image-type-available-p 'xpm)
1466 Valid values are nil, t, `head', `first', `last', an integer or a
1467 predicate. See Info node `(gnus)Customizing Articles' and Info
1468 node `(gnus)Smileys' for details."
1469 :group 'gnus-article-treat
1471 :link '(custom-manual "(gnus)Customizing Articles")
1472 :link '(custom-manual "(gnus)Smileys")
1473 :type gnus-article-treat-custom)
1474 (put 'gnus-treat-display-smileys 'highlight t)
1476 (defcustom gnus-treat-from-picon
1477 (if (and (gnus-image-type-available-p 'xpm)
1478 (gnus-picons-installed-p))
1480 "Display picons in the From header.
1481 Valid values are nil, t, `head', `first', `last', an integer or a
1482 predicate. See Info node `(gnus)Customizing Articles' and Info
1483 node `(gnus)Picons' for details."
1485 :group 'gnus-article-treat
1487 :link '(custom-manual "(gnus)Customizing Articles")
1488 :link '(custom-manual "(gnus)Picons")
1489 :type gnus-article-treat-head-custom)
1490 (put 'gnus-treat-from-picon 'highlight t)
1492 (defcustom gnus-treat-mail-picon
1493 (if (and (gnus-image-type-available-p 'xpm)
1494 (gnus-picons-installed-p))
1496 "Display picons in To and Cc headers.
1497 Valid values are nil, t, `head', `first', `last', an integer or a
1498 predicate. See Info node `(gnus)Customizing Articles' and Info
1499 node `(gnus)Picons' for details."
1501 :group 'gnus-article-treat
1503 :link '(custom-manual "(gnus)Customizing Articles")
1504 :link '(custom-manual "(gnus)Picons")
1505 :type gnus-article-treat-head-custom)
1506 (put 'gnus-treat-mail-picon 'highlight t)
1508 (defcustom gnus-treat-newsgroups-picon
1509 (if (and (gnus-image-type-available-p 'xpm)
1510 (gnus-picons-installed-p))
1512 "Display picons in the Newsgroups and Followup-To headers.
1513 Valid values are nil, t, `head', `first', `last', an integer or a
1514 predicate. See Info node `(gnus)Customizing Articles' and Info
1515 node `(gnus)Picons' for details."
1517 :group 'gnus-article-treat
1519 :link '(custom-manual "(gnus)Customizing Articles")
1520 :link '(custom-manual "(gnus)Picons")
1521 :type gnus-article-treat-head-custom)
1522 (put 'gnus-treat-newsgroups-picon 'highlight t)
1524 (defcustom gnus-treat-body-boundary
1525 (if (or gnus-treat-newsgroups-picon
1526 gnus-treat-mail-picon
1527 gnus-treat-from-picon)
1528 ;; If there's much decoration, the user might prefer a boundery.
1531 "Draw a boundary at the end of the headers.
1532 Valid values are nil and `head'.
1533 See Info node `(gnus)Customizing Articles' for details."
1535 :group 'gnus-article-treat
1536 :link '(custom-manual "(gnus)Customizing Articles")
1537 :type gnus-article-treat-head-custom)
1539 (defcustom gnus-treat-capitalize-sentences nil
1540 "Capitalize sentence-starting words.
1541 Valid values are nil, t, `head', `first', `last', an integer or a
1542 predicate. See Info node `(gnus)Customizing Articles'."
1544 :group 'gnus-article-treat
1545 :link '(custom-manual "(gnus)Customizing Articles")
1546 :type gnus-article-treat-custom)
1548 (defcustom gnus-treat-wash-html nil
1550 Valid values are nil, t, `head', `first', `last', an integer or a
1551 predicate. See Info node `(gnus)Customizing Articles'."
1553 :group 'gnus-article-treat
1554 :link '(custom-manual "(gnus)Customizing Articles")
1555 :type gnus-article-treat-custom)
1557 (defcustom gnus-treat-fill-long-lines nil
1559 Valid values are nil, t, `head', `first', `last', an integer or a
1560 predicate. See Info node `(gnus)Customizing Articles'."
1561 :group 'gnus-article-treat
1562 :link '(custom-manual "(gnus)Customizing Articles")
1563 :type gnus-article-treat-custom)
1565 (defcustom gnus-treat-play-sounds nil
1567 Valid values are nil, t, `head', `first', `last', an integer or a
1568 predicate. See Info node `(gnus)Customizing Articles'."
1570 :group 'gnus-article-treat
1571 :link '(custom-manual "(gnus)Customizing Articles")
1572 :type gnus-article-treat-custom)
1574 (defcustom gnus-treat-translate nil
1575 "Translate articles from one language to another.
1576 Valid values are nil, t, `head', `first', `last', an integer or a
1577 predicate. See Info node `(gnus)Customizing Articles'."
1579 :group 'gnus-article-treat
1580 :link '(custom-manual "(gnus)Customizing Articles")
1581 :type gnus-article-treat-custom)
1583 (defcustom gnus-treat-x-pgp-sig nil
1585 To automatically treat X-PGP-Sig, set it to head.
1586 Valid values are nil, t, `head', `first', `last', an integer or a
1587 predicate. See Info node `(gnus)Customizing Articles'."
1589 :group 'gnus-article-treat
1590 :group 'mime-security
1591 :link '(custom-manual "(gnus)Customizing Articles")
1592 :type gnus-article-treat-custom)
1594 (defvar gnus-article-encrypt-protocol-alist
1595 '(("PGP" . mml2015-self-encrypt)))
1597 ;; Set to nil if more than one protocol added to
1598 ;; gnus-article-encrypt-protocol-alist.
1599 (defcustom gnus-article-encrypt-protocol "PGP"
1600 "The protocol used for encrypt articles.
1601 It is a string, such as \"PGP\". If nil, ask user."
1604 :group 'mime-security)
1606 (defvar gnus-article-wash-function nil
1607 "Function used for converting HTML into text.")
1609 (defcustom gnus-use-idna (and (condition-case nil (require 'idna) (file-error))
1610 (mm-coding-system-p 'utf-8)
1611 (executable-find idna-program))
1612 "Whether IDNA decoding of headers is used when viewing messages.
1613 This requires GNU Libidn, and by default only enabled if it is found."
1615 :group 'gnus-article-headers
1618 (defcustom gnus-article-over-scroll nil
1619 "If non-nil, allow scrolling the article buffer even when there no more text."
1621 :group 'gnus-article
1624 ;;; Internal variables
1626 (defvar gnus-english-month-names
1627 '("January" "February" "March" "April" "May" "June" "July" "August"
1628 "September" "October" "November" "December"))
1630 (defvar article-goto-body-goes-to-point-min-p nil)
1631 (defvar gnus-article-wash-types nil)
1632 (defvar gnus-article-emphasis-alist nil)
1633 (defvar gnus-article-image-alist nil)
1635 (defvar gnus-article-mime-handle-alist-1 nil)
1636 (defvar gnus-treatment-function-alist
1637 '((gnus-treat-x-pgp-sig gnus-article-verify-x-pgp-sig)
1638 (gnus-treat-strip-banner gnus-article-strip-banner)
1639 (gnus-treat-strip-headers-in-body gnus-article-strip-headers-in-body)
1640 (gnus-treat-highlight-signature gnus-article-highlight-signature)
1641 (gnus-treat-buttonize gnus-article-add-buttons)
1642 (gnus-treat-fill-article gnus-article-fill-cited-article)
1643 (gnus-treat-fill-long-lines gnus-article-fill-long-lines)
1644 (gnus-treat-strip-cr gnus-article-remove-cr)
1645 (gnus-treat-unsplit-urls gnus-article-unsplit-urls)
1646 (gnus-treat-date-ut gnus-article-date-ut)
1647 (gnus-treat-date-local gnus-article-date-local)
1648 (gnus-treat-date-english gnus-article-date-english)
1649 (gnus-treat-date-original gnus-article-date-original)
1650 (gnus-treat-date-user-defined gnus-article-date-user)
1651 (gnus-treat-date-iso8601 gnus-article-date-iso8601)
1652 (gnus-treat-date-lapsed gnus-article-date-lapsed)
1653 (gnus-treat-display-x-face gnus-article-display-x-face)
1654 (gnus-treat-display-face gnus-article-display-face)
1655 (gnus-treat-hide-headers gnus-article-maybe-hide-headers)
1656 (gnus-treat-hide-boring-headers gnus-article-hide-boring-headers)
1657 (gnus-treat-hide-signature gnus-article-hide-signature)
1658 (gnus-treat-strip-list-identifiers gnus-article-hide-list-identifiers)
1659 (gnus-treat-leading-whitespace gnus-article-remove-leading-whitespace)
1660 (gnus-treat-strip-pem gnus-article-hide-pem)
1661 (gnus-treat-from-picon gnus-treat-from-picon)
1662 (gnus-treat-mail-picon gnus-treat-mail-picon)
1663 (gnus-treat-newsgroups-picon gnus-treat-newsgroups-picon)
1664 (gnus-treat-highlight-headers gnus-article-highlight-headers)
1665 (gnus-treat-highlight-signature gnus-article-highlight-signature)
1666 (gnus-treat-strip-trailing-blank-lines
1667 gnus-article-remove-trailing-blank-lines)
1668 (gnus-treat-strip-leading-blank-lines
1669 gnus-article-strip-leading-blank-lines)
1670 (gnus-treat-strip-multiple-blank-lines
1671 gnus-article-strip-multiple-blank-lines)
1672 (gnus-treat-overstrike gnus-article-treat-overstrike)
1673 (gnus-treat-ansi-sequences gnus-article-treat-ansi-sequences)
1674 (gnus-treat-unfold-headers gnus-article-treat-unfold-headers)
1675 (gnus-treat-fold-newsgroups gnus-article-treat-fold-newsgroups)
1676 (gnus-treat-fold-headers gnus-article-treat-fold-headers)
1677 (gnus-treat-buttonize-head gnus-article-add-buttons-to-head)
1678 (gnus-treat-display-smileys gnus-treat-smiley)
1679 (gnus-treat-capitalize-sentences gnus-article-capitalize-sentences)
1680 (gnus-treat-wash-html gnus-article-wash-html)
1681 (gnus-treat-emphasize gnus-article-emphasize)
1682 (gnus-treat-hide-citation gnus-article-hide-citation)
1683 (gnus-treat-hide-citation-maybe gnus-article-hide-citation-maybe)
1684 (gnus-treat-highlight-citation gnus-article-highlight-citation)
1685 (gnus-treat-body-boundary gnus-article-treat-body-boundary)
1686 (gnus-treat-play-sounds gnus-earcon-display)))
1688 (defvar gnus-article-mime-handle-alist nil)
1689 (defvar article-lapsed-timer nil)
1690 (defvar gnus-article-current-summary nil)
1692 (defvar gnus-article-mode-syntax-table
1693 (let ((table (copy-syntax-table text-mode-syntax-table)))
1694 ;; This causes the citation match run O(2^n).
1695 ;; (modify-syntax-entry ?- "w" table)
1696 (modify-syntax-entry ?> ")<" table)
1697 (modify-syntax-entry ?< "(>" table)
1698 ;; make M-. in article buffers work for `foo' strings
1699 (modify-syntax-entry ?' " " table)
1700 (modify-syntax-entry ?` " " table)
1702 "Syntax table used in article mode buffers.
1703 Initialized from `text-mode-syntax-table.")
1705 (defvar gnus-save-article-buffer nil)
1707 (defvar gnus-number-of-articles-to-be-saved nil)
1709 (defvar gnus-inhibit-hiding nil)
1711 (defvar gnus-article-edit-mode nil)
1713 ;;; Macros for dealing with the article buffer.
1715 (defmacro gnus-with-article-headers (&rest forms)
1716 `(with-current-buffer gnus-article-buffer
1718 (let ((inhibit-read-only t)
1719 (inhibit-point-motion-hooks t)
1720 (case-fold-search t))
1721 (article-narrow-to-head)
1724 (put 'gnus-with-article-headers 'lisp-indent-function 0)
1725 (put 'gnus-with-article-headers 'edebug-form-spec '(body))
1727 (defmacro gnus-with-article-buffer (&rest forms)
1728 `(with-current-buffer gnus-article-buffer
1729 (let ((inhibit-read-only t))
1732 (put 'gnus-with-article-buffer 'lisp-indent-function 0)
1733 (put 'gnus-with-article-buffer 'edebug-form-spec '(body))
1735 (defun gnus-article-goto-header (header)
1736 "Go to HEADER, which is a regular expression."
1737 (re-search-forward (concat "^\\(" header "\\):") nil t))
1739 (defsubst gnus-article-hide-text (b e props)
1740 "Set text PROPS on the B to E region, extending `intangible' 1 past B."
1741 (gnus-add-text-properties-when 'article-type nil b e props)
1742 (when (memq 'intangible props)
1744 (max (1- b) (point-min))
1745 b 'intangible (cddr (memq 'intangible props)))))
1747 (defsubst gnus-article-unhide-text (b e)
1748 "Remove hidden text properties from region between B and E."
1749 (remove-text-properties b e gnus-hidden-properties)
1750 (when (memq 'intangible gnus-hidden-properties)
1751 (put-text-property (max (1- b) (point-min))
1752 b 'intangible nil)))
1754 (defun gnus-article-hide-text-type (b e type)
1755 "Hide text of TYPE between B and E."
1756 (gnus-add-wash-type type)
1757 (gnus-article-hide-text
1758 b e (cons 'article-type (cons type gnus-hidden-properties))))
1760 (defun gnus-article-unhide-text-type (b e type)
1761 "Unhide text of TYPE between B and E."
1762 (gnus-delete-wash-type type)
1763 (remove-text-properties
1764 b e (cons 'article-type (cons type gnus-hidden-properties)))
1765 (when (memq 'intangible gnus-hidden-properties)
1766 (put-text-property (max (1- b) (point-min))
1767 b 'intangible nil)))
1769 (defun gnus-article-hide-text-of-type (type)
1770 "Hide text of TYPE in the current buffer."
1772 (let ((b (point-min))
1774 (while (setq b (text-property-any b e 'article-type type))
1775 (add-text-properties b (incf b) gnus-hidden-properties)))))
1777 (defun gnus-article-delete-text-of-type (type)
1778 "Delete text of TYPE in the current buffer."
1780 (let ((b (point-min)))
1781 (if (eq type 'multipart)
1782 ;; Remove MIME buttons associated with multipart/alternative parts.
1785 (while (if (get-text-property (point) 'gnus-part)
1787 (when (setq b (next-single-property-change (point)
1792 (skip-chars-forward "\n")
1793 (when (eq (get-text-property b 'article-type) 'multipart)
1794 (delete-region b (point)))))
1795 (while (setq b (text-property-any b (point-max) 'article-type type))
1797 b (or (text-property-not-all b (point-max) 'article-type type)
1800 (defun gnus-article-delete-invisible-text ()
1801 "Delete all invisible text in the current buffer."
1803 (let ((b (point-min)))
1804 (while (setq b (text-property-any b (point-max) 'invisible t))
1806 b (or (text-property-not-all b (point-max) 'invisible t)
1809 (defun gnus-article-text-type-exists-p (type)
1810 "Say whether any text of type TYPE exists in the buffer."
1811 (text-property-any (point-min) (point-max) 'article-type type))
1813 (defsubst gnus-article-header-rank ()
1814 "Give the rank of the string HEADER as given by `gnus-sorted-header-list'."
1815 (let ((list gnus-sorted-header-list)
1818 (if (looking-at (car list))
1820 (setq list (cdr list))
1824 (defun article-hide-headers (&optional arg delete)
1825 "Hide unwanted headers and possibly sort them as well."
1827 ;; This function might be inhibited.
1828 (unless gnus-inhibit-hiding
1829 (let ((inhibit-read-only t)
1830 (case-fold-search t)
1831 (max (1+ (length gnus-sorted-header-list)))
1832 (inhibit-point-motion-hooks t)
1833 (cur (current-buffer))
1834 ignored visible beg)
1836 ;; `gnus-ignored-headers' and `gnus-visible-headers' may be
1837 ;; group parameters, so we should go to the summary buffer.
1840 (progn (set-buffer gnus-summary-buffer) t)
1842 (setq ignored (when (not gnus-visible-headers)
1843 (cond ((stringp gnus-ignored-headers)
1844 gnus-ignored-headers)
1845 ((listp gnus-ignored-headers)
1846 (mapconcat 'identity
1847 gnus-ignored-headers
1849 visible (cond ((stringp gnus-visible-headers)
1850 gnus-visible-headers)
1851 ((and gnus-visible-headers
1852 (listp gnus-visible-headers))
1853 (mapconcat 'identity
1854 gnus-visible-headers
1858 ;; First we narrow to just the headers.
1859 (article-narrow-to-head)
1860 ;; Hide any "From " lines at the beginning of (mail) articles.
1861 (while (looking-at "From ")
1864 (delete-region (point-min) (point)))
1865 ;; Then treat the rest of the header lines.
1866 ;; Then we use the two regular expressions
1867 ;; `gnus-ignored-headers' and `gnus-visible-headers' to
1868 ;; select which header lines is to remain visible in the
1870 (while (re-search-forward "^[^ \t:]*:" nil t)
1872 ;; Mark the rank of the header.
1874 (point) (1+ (point)) 'message-rank
1875 (if (or (and visible (looking-at visible))
1877 (not (looking-at ignored))))
1878 (gnus-article-header-rank)
1881 (message-sort-headers-1)
1882 (when (setq beg (text-property-any
1883 (point-min) (point-max) 'message-rank (+ 2 max)))
1884 ;; We delete the unwanted headers.
1885 (gnus-add-wash-type 'headers)
1886 (add-text-properties (point-min) (+ 5 (point-min))
1887 '(article-type headers dummy-invisible t))
1888 (delete-region beg (point-max))))))))
1890 (defun article-hide-boring-headers (&optional arg)
1891 "Toggle hiding of headers that aren't very interesting.
1892 If given a negative prefix, always show; if given a positive prefix,
1894 (interactive (gnus-article-hidden-arg))
1895 (when (and (not (gnus-article-check-hidden-text 'boring-headers arg))
1896 (not gnus-show-all-headers))
1899 (let ((inhibit-read-only t)
1900 (inhibit-point-motion-hooks t))
1901 (article-narrow-to-head)
1902 (dolist (elem gnus-boring-article-headers)
1903 (goto-char (point-min))
1905 ;; Hide empty headers.
1907 (while (re-search-forward "^[^: \t]+:[ \t]*\n[^ \t]" nil t)
1909 (gnus-article-hide-text-type
1913 (if (re-search-forward "^[^ \t]" nil t)
1917 ;; Hide boring Newsgroups header.
1918 ((eq elem 'newsgroups)
1919 (when (gnus-string-equal
1920 (gnus-fetch-field "newsgroups")
1921 (gnus-group-real-name
1922 (if (boundp 'gnus-newsgroup-name)
1925 (gnus-article-hide-header "newsgroups")))
1926 ((eq elem 'to-address)
1927 (let ((to (message-fetch-field "to"))
1929 (gnus-parameter-to-address
1930 (if (boundp 'gnus-newsgroup-name)
1931 gnus-newsgroup-name ""))))
1932 (when (and to to-address
1935 ;; only one address in To
1936 (nth 1 (mail-extract-address-components to))
1938 (gnus-article-hide-header "to"))))
1940 (let ((to (message-fetch-field "to"))
1942 (gnus-parameter-to-list
1943 (if (boundp 'gnus-newsgroup-name)
1944 gnus-newsgroup-name ""))))
1945 (when (and to to-list
1948 ;; only one address in To
1949 (nth 1 (mail-extract-address-components to))
1951 (gnus-article-hide-header "to"))))
1953 (let ((cc (message-fetch-field "cc"))
1955 (gnus-parameter-to-list
1956 (if (boundp 'gnus-newsgroup-name)
1957 gnus-newsgroup-name ""))))
1958 (when (and cc to-list
1961 ;; only one address in CC
1962 (nth 1 (mail-extract-address-components cc))
1964 (gnus-article-hide-header "cc"))))
1965 ((eq elem 'followup-to)
1966 (when (gnus-string-equal
1967 (message-fetch-field "followup-to")
1968 (message-fetch-field "newsgroups"))
1969 (gnus-article-hide-header "followup-to")))
1970 ((eq elem 'reply-to)
1971 (if (gnus-group-find-parameter
1972 gnus-newsgroup-name 'broken-reply-to)
1973 (gnus-article-hide-header "reply-to")
1974 (let ((from (message-fetch-field "from"))
1975 (reply-to (message-fetch-field "reply-to")))
1982 (lambda (x) (downcase (cadr x)))
1983 (mail-extract-address-components from t))
1986 (lambda (x) (downcase (cadr x)))
1987 (mail-extract-address-components reply-to t))
1989 (gnus-article-hide-header "reply-to")))))
1991 (let ((date (with-current-buffer gnus-original-article-buffer
1992 ;; If date in `gnus-article-buffer' is localized
1993 ;; (`gnus-treat-date-user-defined'),
1994 ;; `days-between' might fail.
1995 (message-fetch-field "date"))))
1997 (< (days-between (current-time-string) date)
1999 (gnus-article-hide-header "date"))))
2001 (let ((to (message-fetch-field "to"))
2002 (cc (message-fetch-field "cc")))
2003 (when (> (length to) 1024)
2004 (gnus-article-hide-header "to"))
2005 (when (> (length cc) 1024)
2006 (gnus-article-hide-header "cc"))))
2010 (goto-char (point-min))
2011 (while (re-search-forward "^to:" nil t)
2012 (setq to-count (1+ to-count)))
2013 (when (> to-count 1)
2014 (while (> to-count 0)
2015 (goto-char (point-min))
2017 (re-search-forward "^to:" nil nil to-count)
2019 (narrow-to-region (point) (point-max))
2020 (gnus-article-hide-header "to"))
2021 (setq to-count (1- to-count))))
2022 (goto-char (point-min))
2023 (while (re-search-forward "^cc:" nil t)
2024 (setq cc-count (1+ cc-count)))
2025 (when (> cc-count 1)
2026 (while (> cc-count 0)
2027 (goto-char (point-min))
2029 (re-search-forward "^cc:" nil nil cc-count)
2031 (narrow-to-region (point) (point-max))
2032 (gnus-article-hide-header "cc"))
2033 (setq cc-count (1- cc-count)))))))))))))
2035 (defun gnus-article-hide-header (header)
2037 (goto-char (point-min))
2038 (when (re-search-forward (concat "^" header ":") nil t)
2039 (gnus-article-hide-text-type
2043 (if (re-search-forward "^[^ \t]" nil t)
2048 (defvar gnus-article-normalized-header-length 40
2049 "Length of normalized headers.")
2051 (defun article-normalize-headers ()
2052 "Make all header lines 40 characters long."
2054 (let ((inhibit-read-only t)
2058 (article-narrow-to-head)
2061 ((< (setq column (- (point-at-eol) (point)))
2062 gnus-article-normalized-header-length)
2064 (insert (make-string
2065 (- gnus-article-normalized-header-length column)
2067 ((> column gnus-article-normalized-header-length)
2068 (gnus-put-text-property
2070 (forward-char gnus-article-normalized-header-length)
2077 (forward-line 1))))))
2079 (defun article-treat-dumbquotes ()
2080 "Translate M****s*** sm*rtq**t*s and other symbols into proper text.
2081 Note that this function guesses whether a character is a sm*rtq**t* or
2082 not, so it should only be used interactively.
2084 Sm*rtq**t*s are M****s***'s unilateral extension to the
2085 iso-8859-1 character map in an attempt to provide more quoting
2086 characters. If you see something like \\222 or \\264 where
2087 you're expecting some kind of apostrophe or quotation mark, then
2090 (article-translate-strings gnus-article-dumbquotes-map))
2092 (defun article-translate-characters (from to)
2093 "Translate all characters in the body of the article according to FROM and TO.
2094 FROM is a string of characters to translate from; to is a string of
2095 characters to translate to."
2097 (when (article-goto-body)
2098 (let ((inhibit-read-only t)
2099 (x (make-string 225 ?x))
2101 (while (< (incf i) (length x))
2104 (while (< i (length from))
2105 (aset x (aref from i) (aref to i))
2107 (translate-region (point) (point-max) x)))))
2109 (defun article-translate-strings (map)
2110 "Translate all string in the body of the article according to MAP.
2111 MAP is an alist where the elements are on the form (\"from\" \"to\")."
2113 (when (article-goto-body)
2114 (let ((inhibit-read-only t))
2117 (while (search-forward (car elem) nil t)
2118 (replace-match (cadr elem)))))))))
2120 (defun article-treat-overstrike ()
2121 "Translate overstrikes into bold text."
2124 (when (article-goto-body)
2125 (let ((inhibit-read-only t))
2126 (while (search-forward "\b" nil t)
2127 (let ((next (char-after))
2128 (previous (char-after (- (point) 2))))
2129 ;; We do the boldification/underlining by hiding the
2130 ;; overstrikes and putting the proper text property
2134 (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike)
2135 (put-text-property (point) (1+ (point)) 'face 'bold))
2137 (gnus-article-hide-text-type
2138 (1- (point)) (1+ (point)) 'overstrike)
2140 (- (point) 2) (1- (point)) 'face 'underline))
2142 (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike)
2144 (point) (1+ (point)) 'face 'underline)))))))))
2146 (defun article-treat-ansi-sequences ()
2147 "Translate ANSI SGR control sequences into overlays or extents."
2150 (when (article-goto-body)
2151 (let ((inhibit-read-only t))
2152 (ansi-color-apply-on-region (point) (point-max))))))
2154 (defun gnus-article-treat-unfold-headers ()
2155 "Unfold folded message headers.
2156 Only the headers that fit into the current window width will be
2159 (gnus-with-article-headers
2163 (mail-header-narrow-to-field)
2164 (let* ((header (buffer-string))
2166 (or (equal gnus-article-unfold-long-headers t)
2167 (and (stringp gnus-article-unfold-long-headers)
2168 (string-match gnus-article-unfold-long-headers header)))))
2171 (goto-char (point-min))
2172 (while (re-search-forward "\n[\t ]" nil t)
2173 (replace-match " " t t)))
2174 (setq length (- (point-max) (point-min) 1))
2175 (when (or unfoldable
2176 (< length (window-width)))
2177 (while (re-search-forward "\n[\t ]" nil t)
2178 (replace-match " " t t))))
2179 (goto-char (point-max)))))))
2181 (defun gnus-article-treat-fold-headers ()
2182 "Fold message headers."
2184 (gnus-with-article-headers
2187 (mail-header-narrow-to-field)
2188 (mail-header-fold-field)
2189 (goto-char (point-max))))))
2191 (defun gnus-treat-smiley ()
2192 "Toggle display of textual emoticons (\"smileys\") as small graphical icons."
2194 (gnus-with-article-buffer
2195 (if (memq 'smiley gnus-article-wash-types)
2196 (gnus-delete-images 'smiley)
2198 (let ((images (smiley-region (point) (point-max))))
2200 (gnus-add-wash-type 'smiley)
2201 (dolist (image images)
2202 (gnus-add-image 'smiley image)))))))
2204 (defun gnus-article-remove-images ()
2205 "Remove all images from the article buffer."
2207 (gnus-with-article-buffer
2208 (dolist (elem gnus-article-image-alist)
2209 (gnus-delete-images (car elem)))))
2211 (defun gnus-article-treat-fold-newsgroups ()
2212 "Unfold folded message headers.
2213 Only the headers that fit into the current window width will be
2216 (gnus-with-article-headers
2217 (while (gnus-article-goto-header "newsgroups\\|followup-to")
2219 (mail-header-narrow-to-field)
2220 (while (re-search-forward ", *" nil t)
2221 (replace-match ", " t t))
2222 (mail-header-fold-field)
2223 (goto-char (point-max))))))
2225 (defcustom gnus-article-truncate-lines (default-value 'truncate-lines)
2226 "Value of `truncate-lines' in Gnus Article buffer.
2227 Valid values are nil, t, `head', `first', `last', an integer or a
2228 predicate. See Info node `(gnus)Customizing Articles'."
2229 :version "23.1" ;; No Gnus
2230 :group 'gnus-article
2231 ;; :link '(custom-manual "(gnus)Customizing Articles")
2234 (defun gnus-article-toggle-truncate-lines (&optional arg)
2235 "Toggle whether to fold or truncate long lines in article the buffer.
2236 If ARG is non-nil and not a number, toggle
2237 `gnus-article-truncate-lines' too. If ARG is a number, truncate
2238 long lines if and only if arg is positive."
2241 ((and (numberp arg) (> arg 0))
2242 (setq gnus-article-truncate-lines t))
2244 (setq gnus-article-truncate-lines nil))
2246 (setq gnus-article-truncate-lines
2247 (not gnus-article-truncate-lines))))
2248 (gnus-with-article-buffer
2250 ((and (numberp arg) (> arg 0))
2251 (setq truncate-lines nil))
2253 (setq truncate-lines t)))
2254 ;; In versions of Emacs 22 (CVS) before 2006-05-26,
2255 ;; `toggle-truncate-lines' needs an argument.
2256 (toggle-truncate-lines)))
2258 (defun gnus-article-treat-body-boundary ()
2259 "Place a boundary line at the end of the headers."
2261 (when (and gnus-body-boundary-delimiter
2262 (> (length gnus-body-boundary-delimiter) 0))
2263 (gnus-with-article-headers
2264 (goto-char (point-max))
2265 (let ((start (point)))
2266 (insert "X-Boundary: ")
2267 (gnus-add-text-properties start (point) '(invisible t intangible t))
2269 (while (>= (1- (window-width)) (length str))
2270 (setq str (concat str gnus-body-boundary-delimiter)))
2271 (substring str 0 (1- (window-width))))
2273 (gnus-put-text-property start (point) 'gnus-decoration 'header)))))
2275 (defun article-fill-long-lines ()
2276 "Fill lines that are wider than the window width."
2279 (let ((inhibit-read-only t)
2280 (width (window-width (get-buffer-window (current-buffer)))))
2283 (let ((adaptive-fill-mode nil)) ;Why? -sm
2286 (when (>= (current-column) (min fill-column width))
2287 (narrow-to-region (min (1+ (point)) (point-max))
2289 (let ((goback (point-marker)))
2290 (fill-paragraph nil)
2291 (goto-char (marker-position goback)))
2293 (forward-line 1)))))))
2295 (defun article-capitalize-sentences ()
2296 "Capitalize the first word in each sentence."
2299 (let ((inhibit-read-only t)
2300 (paragraph-start "^[\n\^L]"))
2304 (forward-sentence)))))
2306 (defun article-remove-cr ()
2307 "Remove trailing CRs and then translate remaining CRs into LFs."
2310 (let ((inhibit-read-only t))
2311 (goto-char (point-min))
2312 (while (re-search-forward "\r+$" nil t)
2313 (replace-match "" t t))
2314 (goto-char (point-min))
2315 (while (search-forward "\r" nil t)
2316 (replace-match "\n" t t)))))
2318 (defun article-remove-trailing-blank-lines ()
2319 "Remove all trailing blank lines from the article."
2322 (let ((inhibit-read-only t))
2323 (goto-char (point-max))
2327 (while (and (not (bobp))
2328 (looking-at "^[ \t]*$")
2329 (not (gnus-annotation-in-region-p
2330 (point) (point-at-eol))))
2335 (defvar gnus-face-properties-alist)
2337 (defun article-display-face (&optional force)
2338 "Display any Face headers in the header."
2339 (interactive (list 'force))
2340 (let ((wash-face-p buffer-read-only))
2341 (gnus-with-article-headers
2342 ;; When displaying parts, this function can be called several times on
2343 ;; the same article, without any intended toggle semantic (as typing `W
2344 ;; D d' would have). So face deletion must occur only when we come from
2345 ;; an interactive command, that is when the *Article* buffer is
2347 (if (and wash-face-p (memq 'face gnus-article-wash-types))
2348 (gnus-delete-images 'face)
2349 (let ((from (message-fetch-field "from"))
2351 (save-current-buffer
2352 (when (and wash-face-p
2353 (gnus-buffer-live-p gnus-original-article-buffer)
2354 (not (re-search-forward "^Face:[\t ]*" nil t)))
2355 (set-buffer gnus-original-article-buffer))
2357 (mail-narrow-to-head)
2359 ;; Check whether this face is censored.
2360 (not (and gnus-article-x-face-too-ugly
2362 (setq from (message-fetch-field "from")))
2363 (string-match gnus-article-x-face-too-ugly
2365 (while (gnus-article-goto-header "Face")
2366 (push (mail-header-field-value) faces)))))
2368 (goto-char (point-min))
2370 (unless (setq from (gnus-article-goto-header "from"))
2373 (insert " [no `from' set]\n"))
2375 (when (setq png (gnus-convert-face-to-png (pop faces)))
2377 (apply 'gnus-create-image png 'png t
2378 (cdr (assq 'png gnus-face-properties-alist))))
2380 (gnus-add-wash-type 'face)
2381 (gnus-add-image 'face image)
2382 (gnus-put-image image nil 'face))))))))))
2384 (defun article-display-x-face (&optional force)
2385 "Look for an X-Face header and display it if present."
2386 (interactive (list 'force))
2387 (let ((wash-face-p buffer-read-only)) ;; When type `W f'
2388 (gnus-with-article-headers
2389 ;; Delete the old process, if any.
2390 (when (process-status "article-x-face")
2391 (delete-process "article-x-face"))
2392 ;; See the comment in `article-display-face'.
2393 (if (and wash-face-p (memq 'xface gnus-article-wash-types))
2394 ;; We have already displayed X-Faces, so we remove them
2396 (gnus-delete-images 'xface)
2398 (let ((from (message-fetch-field "from"))
2400 (save-current-buffer
2401 (when (and wash-face-p
2402 (gnus-buffer-live-p gnus-original-article-buffer)
2403 (not (re-search-forward "^X-Face:[\t ]*" nil t)))
2404 ;; If type `W f', use gnus-original-article-buffer,
2405 ;; otherwise use the current buffer because displaying
2406 ;; RFC822 parts calls this function too.
2407 (set-buffer gnus-original-article-buffer))
2409 (mail-narrow-to-head)
2410 (and gnus-article-x-face-command
2412 ;; Check whether this face is censored.
2413 (not (and gnus-article-x-face-too-ugly
2415 (setq from (message-fetch-field "from")))
2416 (string-match gnus-article-x-face-too-ugly
2418 (while (gnus-article-goto-header "X-Face")
2419 (push (mail-header-field-value) x-faces)))))
2421 ;; We display the face.
2422 (cond ((functionp gnus-article-x-face-command)
2423 ;; The command is a lisp function, so we call it.
2424 (mapc gnus-article-x-face-command x-faces))
2425 ((stringp gnus-article-x-face-command)
2426 ;; The command is a string, so we interpret the command
2427 ;; as a, well, command, and fork it off.
2428 (let ((process-connection-type nil))
2429 (gnus-set-process-query-on-exit-flag
2431 "article-x-face" nil shell-file-name
2432 shell-command-switch gnus-article-x-face-command)
2434 ;; Sending multiple EOFs to xv doesn't work,
2435 ;; so we only do a single external face.
2437 (insert (car x-faces))
2438 (process-send-region "article-x-face"
2439 (point-min) (point-max)))
2440 (process-send-eof "article-x-face")))
2442 (error "`%s' set to `%s' is not a function"
2443 gnus-article-x-face-command
2444 'gnus-article-x-face-command)))))))))
2446 (defun article-decode-mime-words ()
2447 "Decode all MIME-encoded words in the article."
2449 (gnus-with-article-buffer
2450 (let ((inhibit-point-motion-hooks t)
2451 (mail-parse-charset gnus-newsgroup-charset)
2452 (mail-parse-ignored-charsets
2453 (with-current-buffer gnus-summary-buffer
2454 gnus-newsgroup-ignored-charsets)))
2455 (mail-decode-encoded-word-region (point-min) (point-max)))))
2457 (defun article-decode-charset (&optional prompt)
2458 "Decode charset-encoded text in the article.
2459 If PROMPT (the prefix), prompt for a coding system to use."
2461 (let ((inhibit-point-motion-hooks t) (case-fold-search t)
2462 (inhibit-read-only t)
2463 (mail-parse-charset gnus-newsgroup-charset)
2464 (mail-parse-ignored-charsets
2465 (save-excursion (condition-case nil
2466 (set-buffer gnus-summary-buffer)
2468 gnus-newsgroup-ignored-charsets))
2469 ct cte ctl charset format)
2472 (article-narrow-to-head)
2473 (setq ct (message-fetch-field "Content-Type" t)
2474 cte (message-fetch-field "Content-Transfer-Encoding" t)
2475 ctl (and ct (mail-header-parse-content-type ct))
2478 (mm-read-coding-system "Charset to decode: "))
2480 (mail-content-type-get ctl 'charset)))
2481 format (and ctl (mail-content-type-get ctl 'format)))
2483 (setq cte (mail-header-strip cte)))
2484 (if (and ctl (not (string-match "/" (car ctl))))
2486 (goto-char (point-max)))
2489 (narrow-to-region (point) (point-max))
2490 (when (and (eq mail-parse-charset 'gnus-decoded)
2491 (eq (mm-body-7-or-8) '8bit))
2492 ;; The text code could have been decoded.
2493 (setq charset mail-parse-charset))
2494 (when (and (or (not ctl)
2495 (equal (car ctl) "text/plain"))
2496 (not format)) ;; article with format will decode later.
2498 charset (and cte (intern (downcase
2499 (gnus-strip-whitespace cte))))
2502 (defun article-decode-encoded-words ()
2503 "Remove encoded-word encoding from headers."
2504 (let ((inhibit-point-motion-hooks t)
2505 (mail-parse-charset gnus-newsgroup-charset)
2506 (mail-parse-ignored-charsets
2507 (save-excursion (condition-case nil
2508 (set-buffer gnus-summary-buffer)
2510 gnus-newsgroup-ignored-charsets))
2511 (inhibit-read-only t)
2513 (goto-char (point-min))
2514 (when (search-forward "\n\n" nil 'move)
2521 (memq (char-after) '(?\t ? )))))
2522 (setq start (point))
2524 \\(?:Resent-\\)?\\(?:From\\|Cc\\|To\\|Bcc\\|\\(?:In-\\)?Reply-To\\|Sender\
2525 \\|Mail-Followup-To\\|Mail-Copies-To\\|Approved\\):")
2526 (funcall gnus-decode-address-function start end)
2527 (funcall gnus-decode-header-function start end))
2528 (goto-char (setq end start)))))
2530 (defun article-decode-group-name ()
2531 "Decode group names in Newsgroups, Followup-To and Xref headers."
2532 (let ((inhibit-point-motion-hooks t)
2533 (inhibit-read-only t)
2534 (method (gnus-find-method-for-group gnus-newsgroup-name))
2536 (when (and (or gnus-group-name-charset-method-alist
2537 gnus-group-name-charset-group-alist)
2538 (gnus-buffer-live-p gnus-original-article-buffer))
2540 (article-narrow-to-head)
2541 (dolist (header '("Newsgroups" "Followup-To" "Xref"))
2542 (with-current-buffer gnus-original-article-buffer
2543 (goto-char (point-min)))
2544 (setq regexp (concat "^" header
2545 ":\\([^\n]*\\(?:\n[\t ]+[^\n]+\\)*\\)\n"))
2546 (while (re-search-forward regexp nil t)
2547 (replace-match (save-match-data
2548 (gnus-decode-newsgroups
2549 ;; XXX how to use data in article buffer?
2550 (with-current-buffer gnus-original-article-buffer
2551 (re-search-forward regexp nil t)
2553 gnus-newsgroup-name method))
2555 (goto-char (point-min)))))))
2557 (autoload 'idna-to-unicode "idna")
2559 (defun article-decode-idna-rhs ()
2560 "Decode IDNA strings in RHS in various headers in current buffer.
2561 The following headers are decoded: From:, To:, Cc:, Reply-To:,
2562 Mail-Reply-To: and Mail-Followup-To:."
2565 (let ((inhibit-point-motion-hooks t)
2566 (inhibit-read-only t))
2567 (article-narrow-to-head)
2568 (goto-char (point-min))
2569 (while (re-search-forward "@[^ \t\n\r,>]*\\(xn--[-A-Za-z0-9.]*\\)[ \t\n\r,>]" nil t)
2571 (when (save-match-data
2572 (and (setq ace (match-string 1))
2574 (and (re-search-backward "^[^ \t]" nil t)
2575 (looking-at "From\\|To\\|Cc\\|Reply-To\\|Mail-Reply-To\\|Mail-Followup-To")))
2576 (setq unicode (idna-to-unicode ace))))
2577 (unless (string= ace unicode)
2578 (replace-match unicode nil nil nil 1)))))))))
2580 (defun article-de-quoted-unreadable (&optional force read-charset)
2581 "Translate a quoted-printable-encoded article.
2582 If FORCE, decode the article whether it is marked as quoted-printable
2584 If READ-CHARSET, ask for a coding system."
2585 (interactive (list 'force current-prefix-arg))
2587 (let ((inhibit-read-only t) type charset)
2588 (if (gnus-buffer-live-p gnus-original-article-buffer)
2589 (with-current-buffer gnus-original-article-buffer
2591 (gnus-fetch-field "content-transfer-encoding"))
2592 (let* ((ct (gnus-fetch-field "content-type"))
2593 (ctl (and ct (mail-header-parse-content-type ct))))
2594 (setq charset (and ctl
2595 (mail-content-type-get ctl 'charset)))
2596 (if (stringp charset)
2597 (setq charset (intern (downcase charset)))))))
2599 (setq charset (mm-read-coding-system "Charset: " charset)))
2601 (setq charset gnus-newsgroup-charset))
2603 (and type (let ((case-fold-search t))
2604 (string-match "quoted-printable" type))))
2606 (quoted-printable-decode-region
2607 (point) (point-max) (mm-charset-to-coding-system charset))))))
2609 (defun article-de-base64-unreadable (&optional force read-charset)
2610 "Translate a base64 article.
2611 If FORCE, decode the article whether it is marked as base64 not.
2612 If READ-CHARSET, ask for a coding system."
2613 (interactive (list 'force current-prefix-arg))
2615 (let ((inhibit-read-only t) type charset)
2616 (if (gnus-buffer-live-p gnus-original-article-buffer)
2617 (with-current-buffer gnus-original-article-buffer
2619 (gnus-fetch-field "content-transfer-encoding"))
2620 (let* ((ct (gnus-fetch-field "content-type"))
2621 (ctl (and ct (mail-header-parse-content-type ct))))
2622 (setq charset (and ctl
2623 (mail-content-type-get ctl 'charset)))
2624 (if (stringp charset)
2625 (setq charset (intern (downcase charset)))))))
2627 (setq charset (mm-read-coding-system "Charset: " charset)))
2629 (setq charset gnus-newsgroup-charset))
2631 (and type (let ((case-fold-search t))
2632 (string-match "base64" type))))
2635 (narrow-to-region (point) (point-max))
2636 (base64-decode-region (point-min) (point-max))
2637 (mm-decode-coding-region
2638 (point-min) (point-max) (mm-charset-to-coding-system charset)))))))
2643 (defun article-decode-HZ ()
2644 "Translate a HZ-encoded article."
2648 (let ((inhibit-read-only t))
2649 (rfc1843-decode-region (point-min) (point-max)))))
2651 (defun article-unsplit-urls ()
2652 "Remove the newlines that some other mailers insert into URLs."
2655 (let ((inhibit-read-only t))
2656 (goto-char (point-min))
2657 (while (re-search-forward
2658 "\\(\\(https?\\|ftp\\)://\\S-+\\) *\n\\(\\S-+\\)" nil t)
2659 (replace-match "\\1\\3" t)))
2660 (when (interactive-p)
2661 (gnus-treat-article nil))))
2664 (defun article-wash-html (&optional read-charset)
2665 "Format an HTML article.
2666 If READ-CHARSET, ask for a coding system. If it is a number, the
2667 charset defined in `gnus-summary-show-article-charset-alist' is used."
2670 (let ((inhibit-read-only t)
2673 (if (or (and (numberp read-charset)
2677 gnus-summary-show-article-charset-alist))))
2678 (setq charset (mm-read-coding-system "Charset: ")))
2679 (let ((gnus-summary-show-article-charset-alist
2680 (list (cons 1 charset))))
2681 (with-current-buffer gnus-summary-buffer
2682 (gnus-summary-show-article 1)))
2683 (error "No charset is given"))
2684 (when (gnus-buffer-live-p gnus-original-article-buffer)
2685 (with-current-buffer gnus-original-article-buffer
2686 (let* ((ct (gnus-fetch-field "content-type"))
2687 (ctl (and ct (mail-header-parse-content-type ct))))
2688 (setq charset (and ctl
2689 (mail-content-type-get ctl 'charset)))
2690 (when (stringp charset)
2691 (setq charset (intern (downcase charset)))))))
2693 (setq charset gnus-newsgroup-charset)))
2695 (save-window-excursion
2697 (narrow-to-region (point) (point-max))
2698 (let* ((func (or gnus-article-wash-function mm-text-html-renderer))
2699 (entry (assq func mm-text-html-washer-alist)))
2701 (setq func (cdr entry)))
2706 (apply (car func) (cdr func))))))))))
2709 (declare-function w3-region "ext:w3-display" (st nd))
2711 (defun gnus-article-wash-html-with-w3 ()
2712 "Wash the current buffer with w3."
2714 (let ((w3-strict-width (window-width))
2715 (url-standalone-mode t)
2716 (url-gateway-unplugged t)
2717 (w3-honor-stylesheets nil))
2719 (w3-region (point-min) (point-max))
2723 (declare-function w3m-region "ext:w3m" (start end &optional url charset))
2725 (defun gnus-article-wash-html-with-w3m ()
2726 "Wash the current buffer with emacs-w3m."
2728 (let ((w3m-safe-url-regexp mm-w3m-safe-url-regexp)
2729 w3m-force-redisplay)
2730 (w3m-region (point-min) (point-max)))
2731 (when (and mm-inline-text-html-with-w3m-keymap
2732 (boundp 'w3m-minor-mode-map)
2734 (add-text-properties
2735 (point-min) (point-max)
2736 (list 'keymap w3m-minor-mode-map
2737 ;; Put the mark meaning this part was rendered by emacs-w3m.
2738 'mm-inline-text-html-with-w3m t))))
2740 (defvar charset) ;; Bound by `article-wash-html'.
2742 (defun gnus-article-wash-html-with-w3m-standalone ()
2743 "Wash the current buffer with w3m."
2744 (if (mm-w3m-standalone-supports-m17n-p)
2746 (unless (mm-coding-system-p charset) ;; Bound by `article-wash-html'.
2748 (setq charset 'iso-8859-1))
2749 (let ((coding-system-for-write charset)
2750 (coding-system-for-read charset))
2751 (call-process-region
2752 (point-min) (point-max)
2753 "w3m" t t nil "-dump" "-T" "text/html"
2754 "-I" (symbol-name charset) "-O" (symbol-name charset))))
2755 (mm-inline-wash-with-stdin nil "w3m" "-dump" "-T" "text/html")))
2757 (defvar gnus-article-browse-html-temp-list nil
2758 "List of temporary files created by `gnus-article-browse-html-parts'.
2759 Internal variable.")
2761 (defcustom gnus-article-browse-delete-temp 'ask
2762 "What to do with temporary files from `gnus-article-browse-html-parts'.
2763 If nil, don't delete temporary files. If it is t, delete them on
2764 exit from the summary buffer. If it is the symbol `file', query
2765 on each file, if it is `ask' ask once when exiting from the
2767 :group 'gnus-article
2768 :version "23.1" ;; No Gnus
2769 :type '(choice (const :tag "Don't delete" nil)
2770 (const :tag "Don't ask" t)
2771 (const :tag "Ask" ask)
2772 (const :tag "Ask for each file" file)))
2774 ;; Cf. mm-postponed-undisplay-list / mm-destroy-postponed-undisplay-list.
2776 (defun gnus-article-browse-delete-temp-files (&optional how)
2777 "Delete temp-files created by `gnus-article-browse-html-parts'."
2778 (when (and gnus-article-browse-html-temp-list
2780 (setq how gnus-article-browse-delete-temp)))
2781 (when (and (eq how 'ask)
2782 (gnus-y-or-n-p (format
2783 "Delete all %s temporary HTML file(s)? "
2784 (length gnus-article-browse-html-temp-list)))
2786 (dolist (file gnus-article-browse-html-temp-list)
2787 (when (and (file-exists-p file)
2789 ;; `how' is neither `nil', `ask' nor `t' (i.e. `file'):
2791 (format "Delete temporary HTML file `%s'? " file))))
2792 (delete-file file)))
2793 ;; Also remove file from the list when not deleted or if file doesn't
2795 (setq gnus-article-browse-html-temp-list nil))
2796 gnus-article-browse-html-temp-list)
2798 (defun gnus-article-browse-html-parts (list &optional header)
2799 "View all \"text/html\" parts from LIST.
2800 Recurse into multiparts. The optional HEADER that should be a decoded
2801 message header will be added to the bodies of the \"text/html\" parts."
2802 ;; Internal function used by `gnus-article-browse-html-article'.
2803 (let (type file charset tmp-file showed)
2804 ;; Find and show the html-parts.
2805 (dolist (handle list)
2806 ;; If HTML, show it:
2807 (cond ((not (listp handle)))
2808 ((or (equal (car (setq type (mm-handle-type handle))) "text/html")
2809 (and (equal (car type) "message/external-body")
2811 (setq file (or (mail-content-type-get type 'name)
2812 (mail-content-type-get
2813 (mm-handle-disposition handle)
2815 (or (mm-handle-cache handle)
2816 (condition-case code
2817 (progn (mm-extern-cache-contents handle) t)
2819 (gnus-message 3 "%s" (error-message-string code))
2820 (when (>= gnus-verbose 3) (sit-for 2))
2823 (setq handle (mm-handle-cache handle)
2824 type (mm-handle-type handle))
2825 (equal (car type) "text/html"))))
2826 (when (or (setq charset (mail-content-type-get type 'charset))
2829 (setq tmp-file (mm-make-temp-file
2830 ;; Do we need to care for 8.3 filenames?
2831 "mm-" nil ".html")))
2832 ;; Add a meta html tag to specify charset and a header.
2835 (let (title eheader body hcharset coding)
2837 (mm-enable-multibyte)
2838 (setq case-fold-search t)
2839 (insert header "\n")
2840 (setq title (message-fetch-field "subject"))
2841 (goto-char (point-min))
2842 (while (re-search-forward "\\(<\\)\\|\\(>\\)\\|&" nil t)
2843 (replace-match (cond ((match-beginning 1) "<")
2844 ((match-beginning 2) ">")
2846 (goto-char (point-min))
2848 (goto-char (point-max))
2849 (insert "</pre>\n<hr>\n")
2850 ;; We have to examine charset one by one since
2851 ;; charset specified in parts might be different.
2852 (if (eq charset 'gnus-decoded)
2853 (setq charset 'utf-8
2854 eheader (mm-encode-coding-string (buffer-string)
2857 (mm-encode-coding-string title charset))
2858 body (mm-encode-coding-string (mm-get-part handle)
2860 (setq hcharset (mm-find-mime-charset-region (point-min)
2862 (cond ((= (length hcharset) 1)
2863 (setq hcharset (car hcharset)
2864 coding (mm-charset-to-coding-system
2866 ((> (length hcharset) 1)
2867 (setq hcharset 'utf-8
2873 (mm-charset-to-coding-system charset))
2874 (if (eq coding body)
2875 (setq eheader (mm-encode-coding-string
2876 (buffer-string) coding)
2878 (mm-encode-coding-string
2880 body (mm-get-part handle))
2881 (setq charset 'utf-8
2882 eheader (mm-encode-coding-string
2883 (buffer-string) charset)
2885 (mm-encode-coding-string
2887 body (mm-encode-coding-string
2888 (mm-decode-coding-string
2889 (mm-get-part handle) body)
2891 (setq charset hcharset
2892 eheader (mm-encode-coding-string
2893 (buffer-string) coding)
2895 (mm-encode-coding-string
2897 body (mm-get-part handle)))
2898 (setq eheader (mm-string-as-unibyte (buffer-string))
2899 body (mm-get-part handle))))
2901 (mm-disable-multibyte)
2904 (mm-add-meta-html-tag handle charset))
2906 (goto-char (point-min))
2907 (unless (search-forward "<title>" nil t)
2908 (re-search-forward "<head>\\s-*" nil t)
2909 (insert "<title>" title "</title>\n")))
2910 (goto-char (point-min))
2911 (or (re-search-forward
2912 "<body\\(?:\\s-+[^>]+\\|\\s-*\\)>\\s-*" nil t)
2914 "</head\\(?:\\s-+[^>]+\\|\\s-*\\)>\\s-*" nil t))
2916 (mm-write-region (point-min) (point-max)
2917 tmp-file nil nil nil 'binary t))))
2919 (mm-with-unibyte-buffer
2920 (insert (if (eq charset 'gnus-decoded)
2921 (mm-encode-coding-string
2922 (mm-get-part handle)
2923 (setq charset 'utf-8))
2924 (mm-get-part handle)))
2925 (if (or (mm-add-meta-html-tag handle charset)
2927 (mm-write-region (point-min) (point-max)
2928 tmp-file nil nil nil 'binary t)
2929 (setq tmp-file nil))))
2931 (mm-save-part-to-file handle tmp-file)))
2933 (add-to-list 'gnus-article-browse-html-temp-list tmp-file))
2934 (add-hook 'gnus-summary-prepare-exit-hook
2935 'gnus-article-browse-delete-temp-files)
2936 (add-hook 'gnus-exit-gnus-hook
2938 (gnus-article-browse-delete-temp-files t)))
2939 ;; FIXME: Warn if there's an <img> tag?
2940 (browse-url-of-file (or tmp-file (expand-file-name file)))
2942 ;; If multipart, recurse
2943 ((equal (mm-handle-media-supertype handle) "multipart")
2944 (when (gnus-article-browse-html-parts handle header)
2946 ((equal (mm-handle-media-type handle) "message/rfc822")
2947 (mm-with-multibyte-buffer
2948 (mm-insert-part handle)
2949 (setq handle (mm-dissect-buffer t t))
2950 (when (and (bufferp (car handle))
2951 (stringp (car (mm-handle-type handle))))
2952 (setq handle (list handle)))
2954 (article-decode-encoded-words)
2955 (let ((gnus-visible-headers
2956 (or (get 'gnus-visible-headers 'standard-value)
2957 gnus-visible-headers)))
2958 (article-hide-headers))
2959 (goto-char (point-min))
2960 (search-forward "\n\n" nil 'move)
2961 (skip-chars-backward "\t\n ")
2962 (setq header (buffer-substring (point-min) (point)))))
2964 (gnus-article-browse-html-parts handle header)
2965 (mm-destroy-parts handle))
2969 (defun gnus-article-browse-html-article (&optional arg)
2970 "View \"text/html\" parts of the current article with a WWW browser.
2971 The message header is added to the beginning of every html part unless
2972 the prefix argument ARG is given.
2974 Warning: Spammers use links to images in HTML articles to verify
2975 whether you have read the message. As
2976 `gnus-article-browse-html-article' passes the HTML content to the
2977 browser without eliminating these \"web bugs\" you should only
2978 use it for mails from trusted senders.
2980 If you always want to display HTML parts in the browser, set
2981 `mm-text-html-renderer' to nil."
2982 ;; Cf. `mm-w3m-safe-url-regexp'
2985 (gnus-summary-show-article)
2986 (let ((gnus-visible-headers (or (get 'gnus-visible-headers 'standard-value)
2987 gnus-visible-headers))
2988 ;; As we insert a <hr>, there's no need for the body boundary.
2989 (gnus-treat-body-boundary nil))
2990 (gnus-summary-show-article)))
2991 (with-current-buffer gnus-article-buffer
2992 (let ((header (unless arg
2995 (buffer-substring-no-properties
2996 (goto-char (point-min))
2997 (if (search-forward "\n\n" nil t)
2999 (goto-char (point-max))
3000 (skip-chars-backward "\t\n ")
3003 (set-buffer gnus-original-article-buffer)
3004 (setq parts (mm-dissect-buffer t t))
3005 ;; If singlepart, enforce a list.
3006 (when (and (bufferp (car parts))
3007 (stringp (car (mm-handle-type parts))))
3008 (setq parts (list parts)))
3010 (unless (gnus-article-browse-html-parts parts header)
3011 (gnus-error 3 "Mail doesn't contain a \"text/html\" part!"))
3012 (mm-destroy-parts parts)
3014 (gnus-summary-show-article)))))
3016 (defun article-hide-list-identifiers ()
3017 "Remove list identifies from the Subject header.
3018 The `gnus-list-identifiers' variable specifies what to do."
3020 (let ((inhibit-point-motion-hooks t)
3021 (regexp (if (consp gnus-list-identifiers)
3022 (mapconcat 'identity gnus-list-identifiers " *\\|")
3023 gnus-list-identifiers))
3024 (inhibit-read-only t))
3028 (article-narrow-to-head)
3029 (goto-char (point-min))
3030 (while (re-search-forward
3031 (concat "^Subject: +\\(R[Ee]: +\\)*\\(" regexp " *\\)")
3033 (delete-region (match-beginning 2) (match-end 0))
3034 (beginning-of-line))
3035 (when (re-search-forward
3036 "^Subject: +\\(\\(R[Ee]: +\\)+\\)R[Ee]: +" nil t)
3037 (delete-region (match-beginning 1) (match-end 1))))))))
3039 (defun article-hide-pem (&optional arg)
3040 "Toggle hiding of any PEM headers and signatures in the current article.
3041 If given a negative prefix, always show; if given a positive prefix,
3043 (interactive (gnus-article-hidden-arg))
3044 (unless (gnus-article-check-hidden-text 'pem arg)
3046 (let ((inhibit-read-only t) end)
3047 (goto-char (point-min))
3048 ;; Hide the horrendously ugly "header".
3049 (when (and (search-forward
3050 "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n"
3052 (setq end (1+ (match-beginning 0))))
3053 (gnus-add-wash-type 'pem)
3054 (gnus-article-hide-text-type
3056 (if (search-forward "\n\n" nil t)
3060 ;; Hide the trailer as well
3061 (when (search-forward "\n-----END PRIVACY-ENHANCED MESSAGE-----\n"
3063 (gnus-article-hide-text-type
3064 (match-beginning 0) (match-end 0) 'pem)))))))
3066 (defun article-strip-banner ()
3067 "Strip the banners specified by the `banner' group parameter and by
3068 `gnus-article-address-banner-alist'."
3072 (let ((inhibit-point-motion-hooks t))
3073 (when (gnus-parameter-banner gnus-newsgroup-name)
3074 (article-really-strip-banner
3075 (gnus-parameter-banner gnus-newsgroup-name)))
3076 (when gnus-article-address-banner-alist
3077 ;; Note that the From header is decoded here, so it is
3078 ;; required that the *-extract-address-components function
3079 ;; supports non-ASCII text.
3080 (let ((from (save-restriction
3082 (article-narrow-to-head)
3083 (mail-fetch-field "from"))))
3086 (cadr (funcall gnus-extract-address-components
3089 (dolist (pair gnus-article-address-banner-alist)
3090 (when (string-match (car pair) from)
3092 (article-really-strip-banner (cdr pair)))))))))))))
3094 (defun article-really-strip-banner (banner)
3095 "Strip the banner specified by the argument."
3098 (let ((inhibit-point-motion-hooks t)
3099 (gnus-signature-limit nil)
3100 (inhibit-read-only t))
3103 ((eq banner 'signature)
3104 (when (gnus-article-narrow-to-signature)
3107 (delete-region (point) (point-max))))
3109 (if (setq banner (cdr (assq banner gnus-article-banner-alist)))
3110 (while (re-search-forward banner nil t)
3111 (delete-region (match-beginning 0) (match-end 0)))))
3113 (while (re-search-forward banner nil t)
3114 (delete-region (match-beginning 0) (match-end 0)))))))))
3116 (defun article-babel ()
3117 "Translate article using an online translation service."
3120 (gnus-with-article-buffer
3121 (when (article-goto-body)
3122 (let* ((start (point))
3124 (orig (buffer-substring start end))
3125 (trans (babel-as-string orig)))
3127 (narrow-to-region start end)
3128 (delete-region start end)
3131 (defun article-hide-signature (&optional arg)
3132 "Hide the signature in the current article.
3133 If given a negative prefix, always show; if given a positive prefix,
3135 (interactive (gnus-article-hidden-arg))
3136 (unless (gnus-article-check-hidden-text 'signature arg)
3139 (let ((inhibit-read-only t))
3140 (when (gnus-article-narrow-to-signature)
3141 (gnus-article-hide-text-type
3142 (point-min) (point-max) 'signature))))))
3143 (gnus-set-mode-line 'article))
3145 (defun article-strip-headers-in-body ()
3146 "Strip offensive headers from bodies."
3150 (let ((case-fold-search t))
3151 (when (looking-at "x-no-archive:")
3152 (gnus-delete-line)))))
3154 (defun article-strip-leading-blank-lines ()
3155 "Remove all blank lines from the beginning of the article."
3158 (let ((inhibit-point-motion-hooks t)
3159 (inhibit-read-only t))
3160 (when (article-goto-body)
3161 (while (and (not (eobp))
3162 (looking-at "[ \t]*$"))
3163 (gnus-delete-line))))))
3165 (defun article-narrow-to-head ()
3166 "Narrow the buffer to the head of the message.
3167 Point is left at the beginning of the narrowed-to region."
3169 (goto-char (point-min))
3170 (if (search-forward "\n\n" nil 1)
3173 (goto-char (point-min)))
3175 (defun article-goto-body ()
3176 "Place point at the start of the body."
3177 (goto-char (point-min))
3179 ;; This variable is only bound when dealing with separate
3181 (article-goto-body-goes-to-point-min-p
3183 ((search-forward "\n\n" nil t)
3186 (goto-char (point-max))
3189 (defun article-strip-multiple-blank-lines ()
3190 "Replace consecutive blank lines with one empty line."
3193 (let ((inhibit-point-motion-hooks t)
3194 (inhibit-read-only t))
3195 ;; First make all blank lines empty.
3197 (while (re-search-forward "^[ \t]+$" nil t)
3198 (unless (gnus-annotation-in-region-p
3199 (match-beginning 0) (match-end 0))
3200 (replace-match "" nil t)))
3201 ;; Then replace multiple empty lines with a single empty line.
3203 (while (re-search-forward "\n\n\\(\n+\\)" nil t)
3204 (unless (gnus-annotation-in-region-p
3205 (match-beginning 0) (match-end 0))
3206 (delete-region (match-beginning 1) (match-end 1)))))))
3208 (defun article-strip-leading-space ()
3209 "Remove all white space from the beginning of the lines in the article."
3212 (let ((inhibit-point-motion-hooks t)
3213 (inhibit-read-only t))
3215 (while (re-search-forward "^[ \t]+" nil t)
3216 (replace-match "" t t)))))
3218 (defun article-strip-trailing-space ()
3219 "Remove all white space from the end of the lines in the article."
3222 (let ((inhibit-point-motion-hooks t)
3223 (inhibit-read-only t))
3225 (while (re-search-forward "[ \t]+$" nil t)
3226 (replace-match "" t t)))))
3228 (defun article-strip-blank-lines ()
3229 "Strip leading, trailing and multiple blank lines."
3231 (article-strip-leading-blank-lines)
3232 (article-remove-trailing-blank-lines)
3233 (article-strip-multiple-blank-lines))
3235 (defun article-strip-all-blank-lines ()
3236 "Strip all blank lines."
3239 (let ((inhibit-point-motion-hooks t)
3240 (inhibit-read-only t))
3242 (while (re-search-forward "^[ \t]*\n" nil t)
3243 (replace-match "" t t)))))
3245 (defun gnus-article-narrow-to-signature ()
3246 "Narrow to the signature; return t if a signature is found, else nil."
3247 (let ((inhibit-point-motion-hooks t))
3248 (when (gnus-article-search-signature)
3250 ;; Check whether we have some limits to what we consider
3251 ;; to be a signature.
3252 (let ((limits (if (listp gnus-signature-limit) gnus-signature-limit
3253 (list gnus-signature-limit)))
3255 (while (setq limit (pop limits))
3256 (if (or (and (integerp limit)
3257 (< (- (point-max) (point)) limit))
3259 (< (count-lines (point) (point-max)) limit))
3260 (and (functionp limit)
3262 (and (stringp limit)
3263 (not (re-search-forward limit nil t))))
3264 () ; This limit did not succeed.
3268 (narrow-to-region (point) (point-max))
3271 (defun gnus-article-search-signature ()
3272 "Search the current buffer for the signature separator.
3273 Put point at the beginning of the signature separator."
3274 (let ((cur (point)))
3275 (goto-char (point-max))
3276 (if (if (stringp gnus-signature-separator)
3277 (re-search-backward gnus-signature-separator nil t)
3278 (let ((seps gnus-signature-separator))
3280 (not (re-search-backward (car seps) nil t)))
3287 (defun gnus-article-hidden-arg ()
3288 "Return the current prefix arg as a number, or 0 if no prefix."
3289 (list (if current-prefix-arg
3290 (prefix-numeric-value current-prefix-arg)
3293 (defun gnus-article-check-hidden-text (type arg)
3294 "Return nil if hiding is necessary.
3295 Arg can be nil or a number. nil and positive means hide, negative
3296 means show, 0 means toggle."
3299 (let ((hide (gnus-article-hidden-text-p type)))
3305 (gnus-article-show-hidden-text type)
3308 (if (eq hide 'hidden)
3310 (gnus-article-show-hidden-text type)
3314 (defun gnus-article-hidden-text-p (type)
3315 "Say whether the current buffer contains hidden text of type TYPE."
3316 (let ((pos (text-property-any (point-min) (point-max) 'article-type type)))
3318 (not (get-text-property pos 'invisible))
3319 (not (get-text-property pos 'dummy-invisible)))
3321 (text-property-any (1+ pos) (point-max) 'article-type type)))
3326 (defun gnus-article-show-hidden-text (type &optional dummy)
3327 "Show all hidden text of type TYPE.
3328 Originally it is hide instead of DUMMY."
3329 (let ((inhibit-read-only t)
3330 (inhibit-point-motion-hooks t))
3331 (gnus-remove-text-properties-when
3333 (point-min) (point-max)
3334 (cons 'article-type (cons type
3335 gnus-hidden-properties)))
3336 (gnus-delete-wash-type type)))
3338 (defconst article-time-units
3339 `((year . ,(* 365.25 24 60 60))
3340 (week . ,(* 7 24 60 60))
3341 (day . ,(* 24 60 60))
3345 "Mapping from time units to seconds.")
3347 (defun gnus-article-forward-header ()
3348 "Move point to the start of the next header.
3349 If the current header is a continuation header, this can be several
3354 (if (looking-at "[ \t]+[^ \t]")
3358 (defun article-date-ut (&optional type highlight)
3359 "Convert DATE date to universal time in the current article.
3360 If TYPE is `local', convert to local time; if it is `lapsed', output
3361 how much time has lapsed since DATE. For `lapsed', the value of
3362 `gnus-article-date-lapsed-new-header' says whether the \"X-Sent:\" header
3363 should replace the \"Date:\" one, or should be added below it."
3364 (interactive (list 'ut t))
3365 (let* ((tdate-regexp "^Date:[ \t]\\|^X-Sent:[ \t]")
3366 (date-regexp (cond ((not gnus-article-date-lapsed-new-header)
3370 (article-lapsed-timer
3374 (case-fold-search t)
3375 (inhibit-read-only t)
3376 (inhibit-point-motion-hooks t)
3377 pos date bface eface)
3381 (goto-char (point-min))
3382 (while (or (setq date (get-text-property (setq pos (point))
3384 (when (setq pos (next-single-property-change
3385 (point) 'original-date))
3386 (setq date (get-text-property pos 'original-date))
3388 (narrow-to-region pos (or (text-property-any pos (point-max)
3391 (goto-char (point-min))
3392 (when (re-search-forward tdate-regexp nil t)
3393 (setq bface (get-text-property (point-at-bol) 'face)
3394 eface (get-text-property (1- (point-at-eol)) 'face)))
3395 (goto-char (point-min))
3397 ;; Delete any old Date headers.
3398 (while (re-search-forward date-regexp nil t)
3400 (delete-region (point-at-bol) (progn
3401 (gnus-article-forward-header)
3403 (delete-region (point-at-bol) (progn
3404 (gnus-article-forward-header)
3407 (setq pos (point))))
3408 (when (and (not pos)
3409 (re-search-forward tdate-regexp nil t))
3411 (gnus-goto-char pos)
3412 (insert (article-make-date-line date (or type 'ut)))
3418 (when (looking-at "\\([^:]+\\): *\\(.*\\)$")
3419 (put-text-property (match-beginning 1) (1+ (match-end 1))
3421 (put-text-property (match-beginning 2) (match-end 2)
3423 (put-text-property (point-min) (1- (point-max)) 'original-date date)
3424 (goto-char (point-max))
3427 (defun article-make-date-line (date type)
3428 "Return a DATE line of TYPE."
3429 (unless (memq type '(local ut original user iso8601 lapsed english))
3430 (error "Unknown conversion type: %s" type))
3432 (let ((time (date-to-time date)))
3434 ;; Convert to the local timezone.
3436 (concat "Date: " (message-make-date time)))
3437 ;; Convert to Universal Time.
3442 (let* ((e (parse-time-string date))
3443 (tm (apply 'encode-time e))
3445 (ls (- (cadr tm) (car (current-time-zone time)))))
3446 (cond ((< ls 0) (list (1- ms) (+ ls 65536)))
3447 ((> ls 65535) (list (1+ ms) (- ls 65536)))
3451 ;; Get the original date from the article.
3452 ((eq type 'original)
3453 (concat "Date: " (if (string-match "\n+$" date)
3454 (substring date 0 (match-beginning 0))
3456 ;; Let the user define the format.
3458 (let ((format (or (condition-case nil
3459 (with-current-buffer gnus-summary-buffer
3460 gnus-article-time-format)
3462 gnus-article-time-format)))
3463 (if (functionp format)
3464 (funcall format time)
3465 (concat "Date: " (format-time-string format time)))))
3468 (let ((tz (car (current-time-zone time))))
3471 (format-time-string "%Y%m%dT%H%M%S" time)
3472 (format "%s%02d%02d"
3473 (if (> tz 0) "+" "-") (/ (abs tz) 3600)
3474 (/ (% (abs tz) 3600) 60)))))
3475 ;; Do an X-Sent lapsed format.
3477 ;; If the date is seriously mangled, the timezone functions are
3478 ;; liable to bug out, so we ignore all errors.
3479 (let* ((now (current-time))
3480 (real-time (subtract-time now time))
3481 (real-sec (and real-time
3482 (+ (* (float (car real-time)) 65536)
3484 (sec (and real-time (abs real-sec)))
3494 ;; This is a bit convoluted, but basically we go
3495 ;; through the time units for years, weeks, etc,
3496 ;; and divide things to see whether that results
3497 ;; in positive answers.