| blob | 53da05e939ba2d802b063907684a66ce9237a36c |
1 ;;; gnus-art.el --- article mode commands for Gnus
3 ;; Copyright (C) 1996-2014 Free Software Foundation, Inc.
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
6 ;; Keywords: news
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
23 ;;; Commentary:
25 ;;; Code:
55 "Article display."
60 "Treating article parts."
65 "Hiding article parts."
70 "Article highlighting."
76 "Article signatures."
81 "Article headers."
86 "Special commands on articles."
91 "Fontisizing articles."
96 "Saving articles."
101 "Worshiping the MIME wonder."
106 "Pushable buttons in the article buffer."
111 "Other article options."
160 "*All headers that start with this regexp will be hidden.
161 This variable can also be a list of regexps of headers to be ignored.
162 If `gnus-visible-headers' is non-nil, this variable will be ignored."
168 "^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:"
169 "*All headers that do not match this regexp will be hidden.
170 This variable can also be a list of regexp of headers to remain visible.
171 If this variable is non-nil, `gnus-ignored-headers' will be ignored."
178 regexp)
180 regexp)
186 "*This variable is a list of regular expressions.
187 If it is non-nil, headers that match the regular expressions will
188 be placed first in the article buffer in the sequence specified by
189 this list."
194 "Headers that are only to be displayed if they have interesting data.
195 Possible values in this list are:
197 'empty Headers with no content.
198 'newsgroups Newsgroup identical to Gnus group.
199 'to-address To identical to To-address.
200 'to-list To identical to To-list.
201 'cc-list CC identical to To-list.
202 'followup-to Followup-to identical to Newsgroups.
203 'reply-to Reply-to identical to From.
204 'date Date less than four days old.
205 'long-to To and/or Cc longer than 1024 characters.
206 'many-to Multiple To and/or Cc."
220 "Skip over text that is not worth reading.
221 By default, if you set this t, then Gnus will display citations and
222 signatures, but will never scroll down to show you a page consisting
223 only of boring text. Boring text is controlled by
224 `gnus-article-boring-faces'."
230 "Regexp matching signature separator.
231 This can also be a list of regexps. In that case, it will be checked
232 from head to tail looking for a separator. Searches will be done from
233 the end of the buffer."
240 "Provide a limit to what is considered a signature.
241 If it is a number, no signature may not be longer (in characters) than
242 that number. If it is a floating point number, no signature may be
243 longer (in lines) than that number. If it is a function, the function
244 will be called without any parameters, and if it returns nil, there is
245 no signature in the buffer. If it is a string, it will be used as a
246 regexp. If it matches, the text in question is not a signature.
248 This can also be a list of the above values."
252 function
258 ;; `intangible' is evil, but I keep it here in case it's useful.
260 ;; Emacs's command loop moves point out of invisible text anyway, so
261 ;; `intangible' is clearly not needed there.
263 "Property list to use for hiding text."
267 ;; Fixme: This isn't the right thing for mixed graphical and non-graphical
268 ;; frames in a session.
273 'gnus-display-x-face-in-from
274 "{ echo \
275 '/* Format_version=1, Width=48, Height=48, Depth=1, Valid_bits_per_item=16 */'\
278 'gnus-display-x-face-in-from
279 "{ echo \
280 '/* Format_version=1, Width=48, Height=48, Depth=1, Valid_bits_per_item=16 */'\
282 "*String or function to be executed to display an X-Face header.
283 If it is a string, the command will be executed in a sub-shell
284 asynchronously. The compressed face will be piped to this command."
287 function)
293 "Regexp matching posters whose face shouldn't be shown automatically."
298 "Banner alist for stripping.
299 For example,
300 ((egroups . \"^[ \\t\\n]*-------------------+\\\\( \\\\(e\\\\|Yahoo! \\\\)Groups Sponsor -+\\\\)?....\\n\\\\(.+\\n\\\\)+\"))"
306 banner
307 :variable-document
308 "Alist of regexps (to match group names) and banner."
309 :variable-group gnus-article-washing
310 :parameter-type
312 :value nil
315 regexp
317 :parameter-document
318 "If non-nil, specify how to remove `banners' from articles.
320 Symbol `signature' means to remove signatures delimited by
321 `gnus-signature-separator'. Any other symbol is used to look up a
322 regular expression to match the banner in `gnus-article-banner-alist'.
323 A string is used as a regular expression to match the banner
327 "Alist of mail addresses and banners.
328 Each element has the form (ADDRESS . BANNER), where ADDRESS is a regexp
329 to match a mail address in the From: header, BANNER is one of a symbol
330 `signature', an item in `gnus-article-banner-alist', a regexp and nil.
331 If ADDRESS matches author's mail address, it will remove things like
332 advertisements. For example:
335 "
342 regexp
357 2
360 value)))
368 pattern)
373 value))))
391 types))
393 ;; several times seen it triggered by normal text. --Stef
394 ;; Miles suggests that this form is sometimes used but for italics,
395 ;; so maybe we should map it to `italic'.
396 ;; ("\\(\\s-\\|^\\)\\(-\\(\\(\\w\\|-[^-]\\)+\\)-\\)\\(\\s-\\|[?!.,;]\\)"
397 ;; 2 3 gnus-emphasis-strikethru)
400 "*Alist that says how to fontify certain phrases.
401 Each item looks like this:
405 The first element is a regular expression to be matched. The second
406 is a number that says what regular expression grouping used to find
407 the entire emphasized word. The third is a number that says what
408 regexp grouping should be displayed and highlighted. The fourth
409 is the face used for highlighting."
410 :type
417 :value-create
425 widget
426 :value
429 regexp
432 face)
440 face)))
446 value)))
450 "A regexp to describe whitespace which should not be emphasized.
452 The former avoids underlining of leading and trailing whitespace,
453 and the latter avoids underlining any whitespace at all."
459 "Face used for displaying strong emphasized text (*word*)."
463 "Face used for displaying italic emphasized text (/word/)."
467 "Face used for displaying underlined emphasized text (_word_)."
471 "Face used for displaying underlined bold emphasized text (_*word*_)."
475 "Face used for displaying underlined italic emphasized text (_/word/_)."
479 "Face used for displaying bold italic emphasized text (/*word*/)."
484 "Face used for displaying underlined bold italic emphasized text.
485 Example: (_/*word*/_)."
491 "Face used for displaying strike-through text (-word-)."
496 "Face used for displaying highlighted words."
500 "Format for display of Date headers in article bodies.
501 See `format-time-string' for the possible values.
503 The variable can also be function, which should return a complete Date
504 header. The function is called with one argument, the time, which can
505 be fed to `format-time-string'."
511 "*If non-nil, don't remove any headers before saving.
512 This will be overridden by the `:headers' property that the symbol of
513 the saver function, which is specified by `gnus-default-article-saver',
514 might have."
519 "*This variable says how much prompting is to be done when saving articles.
520 If it is nil, no prompting will be done, and the articles will be
521 saved to the default files. If this variable is `always', each and
522 every article that is saved will be preceded by a prompt, even when
523 saving large batches of articles. If this variable is neither nil not
524 `always', there the user will be prompted once for a file name for
525 each invocation of the saving commands."
532 "Headers to keep if `gnus-save-all-headers' is nil.
533 If `gnus-save-all-headers' is non-nil, this variable will be ignored.
534 If that variable is nil, however, all headers that match this regexp
535 will be kept while the rest will be deleted before saving. This and
536 `gnus-save-all-headers' will be overridden by the `:headers' property
537 that the symbol of the saver function, which is specified by
538 `gnus-default-article-saver', might have."
542 ;; Note that "Rmail format" is mbox since Emacs 23, but Babyl before.
544 "A function to save articles in your favorite format.
545 The function will be called by way of the `gnus-summary-save-article'
546 command, and friends such as `gnus-summary-save-article-rmail'.
548 Gnus provides the following functions:
550 * gnus-summary-save-in-rmail (Rmail format)
551 * gnus-summary-save-in-mail (Unix mail format)
552 * gnus-summary-save-in-folder (MH folder)
553 * gnus-summary-save-in-file (article format)
554 * gnus-summary-save-body-in-file (article body)
555 * gnus-summary-save-in-vm (use VM's folder format)
556 * gnus-summary-write-to-file (article format -- overwrite)
557 * gnus-summary-write-body-to-file (article body -- overwrite)
558 * gnus-summary-save-in-pipe (article format)
560 The symbol of each function may have the following properties:
562 * :decode
563 The value non-nil means save decoded articles. This is meaningful
564 only with `gnus-summary-save-in-file', `gnus-summary-save-body-in-file',
565 `gnus-summary-write-to-file', `gnus-summary-write-body-to-file', and
566 `gnus-summary-save-in-pipe'.
568 * :function
569 The value specifies an alternative function which appends, not
570 overwrites, articles to a file. This implies that when saving many
571 articles at a time, `gnus-prompt-before-saving' is bound to t and all
572 articles are saved in a single file. This is meaningful only with
573 `gnus-summary-write-to-file' and `gnus-summary-write-body-to-file'.
575 * :headers
576 The value specifies the symbol of a variable of which the value
577 specifies headers to be saved. If it is omitted,
578 `gnus-save-all-headers' and `gnus-saved-headers' control what
579 headers should be saved."
597 "Coding system used to save decoded articles to a file.
599 The recommended coding systems are `utf-8', `iso-2022-7bit' and so on,
600 which can safely encode any characters in text. This is used by the
601 commands including:
603 * gnus-summary-save-article-file
604 * gnus-summary-save-article-body-file
605 * gnus-summary-write-article-file
606 * gnus-summary-write-article-body-file
608 and the functions to which you may set `gnus-default-article-saver':
610 * gnus-summary-save-in-file
611 * gnus-summary-save-body-in-file
612 * gnus-summary-write-to-file
613 * gnus-summary-write-body-to-file
615 Those commands and functions save just text displayed in the article
616 buffer to a file if the value of this variable is non-nil. Note that
617 buttonized MIME parts will be lost in a saved file in that case.
618 Otherwise, raw articles will be saved."
633 "A function generating a file name to save articles in Rmail format.
634 The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE."
639 "A function generating a file name to save articles in Unix mail format.
640 The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE."
645 "A function generating a file name to save articles in MH folder.
646 The function is called with NEWSGROUP, HEADERS, and optional LAST-FOLDER."
651 "A function generating a file name to save articles in article format.
652 The function is called with NEWSGROUP, HEADERS, and optional
653 LAST-FILE."
660 "*Variable used to suggest where articles are to be saved.
661 For instance, if you would like to save articles related to Gnus in
663 you could set this variable to something like:
668 This variable is an alist where the key is the match and the
669 value is a list of possible files to save in if the match is
670 non-nil.
672 If the match is a string, it is used as a regexp match on the
673 article. If the match is a symbol, that symbol will be funcalled
674 from the buffer of the article to be saved with the newsgroup as the
675 parameter. If it is a list, it will be evalled in the same buffer.
677 If this form or function returns a string, this string will be used as a
678 possible file name; and if it returns a non-nil list, that list will be
679 used as possible file names."
686 "*Regexp describing what to use as article page delimiters.
688 beginning of a line."
693 "*The format specification for the article mode line.
694 See `gnus-summary-mode-line-format' for a closer description.
696 The following additional specs are available:
698 %w The article washing status.
699 %m The number of MIME parts in the article."
705 "*A hook for Gnus article mode."
710 ;; Extracted from gnus-xmas-define in order to preserve user settings
713 ;; Extracted from gnus-xmas-redefine in order to preserve user settings
717 "*Hook run after the creation of the article mode menu."
722 "*A hook called after an article has been prepared in the article buffer."
727 "List of headers to be removed when copying an article.
728 Each element is a regular expression."
738 "Face used for highlighting a button in the article buffer."
742 "Face used for highlighting buttons in the article buffer.
744 An article button is a piece of text that you can activate by pressing
745 `RET' or `mouse-2' above it."
750 "Face used for mouse highlighting in the article buffer.
752 Article buttons will be displayed in this face when the cursor is
753 above them."
758 "Face used for highlighting a signature in the article buffer.
759 Obsolete; use the face `gnus-signature' for customizations instead."
767 "Face used for highlighting a signature in the article buffer."
770 ;; backward-compatibility alias
783 "Face used for displaying from headers."
786 ;; backward-compatibility alias
799 "Face used for displaying subject headers."
802 ;; backward-compatibility alias
815 "Face used for displaying newsgroups headers.
816 In the default setup this face is only used for crossposted
817 articles."
820 ;; backward-compatibility alias
833 "Face used for displaying header names."
836 ;; backward-compatibility alias
851 ;; backward-compatibility alias
860 "*Controls highlighting of article headers.
862 An alist of the form (HEADER NAME CONTENT).
864 HEADER is a regular expression which should match the name of a
865 header and NAME and CONTENT are either face names or nil.
867 The name of each header field will be displayed using the face
868 specified by the first element in the list where HEADER matches
869 the header name and NAME is non-nil. Similarly, the content will
870 be displayed by the first non-nil matching CONTENT face."
885 "Alist of image types and properties applied to Face and X-Face images.
886 Here are examples:
888 ;; Specify the altitude of Face images in the From header.
889 \(setq gnus-face-properties-alist
890 '((pbm . (:face gnus-x-face :ascent 80))
891 (png . (:ascent 80))))
893 ;; Show Face images as pressed buttons.
894 \(setq gnus-face-properties-alist
895 '((pbm . (:face gnus-x-face :relief -2))
896 (png . (:relief -2))))
898 See the manual for the valid properties for various image types.
899 Currently, `pbm' is used for X-Face images and `png' is used for Face
900 images in Emacs. Only the `:face' property is effective on the `xface'
901 image type in XEmacs if it is built with the libcompface library."
908 article-decode-group-name article-decode-idna-rhs)
909 "*Hook run to decode charsets in articles."
914 "Function to display MIME articles."
947 "List of MIME types that should be ignored by Gnus."
953 "List of MIME types that should not be given buttons when rendered inline.
954 See also `gnus-buttonized-mime-types' which may override this variable.
955 This variable is only used when `gnus-inhibit-mime-unbuttonizing' is nil."
961 "List of MIME types that should be given buttons when rendered inline.
962 If set, this variable overrides `gnus-unbuttonized-mime-types'.
963 To see e.g. security buttons you could set this to
965 this list to display radio buttons that allow you to choose one of two
966 media types those mails include. See also `mm-discouraged-alternatives'.
967 This variable is only used when `gnus-inhibit-mime-unbuttonizing' is nil."
973 "If non-nil, all MIME parts get buttons.
974 When nil (the default value), then some MIME parts do not get buttons,
975 as described by the variables `gnus-buttonized-mime-types' and
976 `gnus-unbuttonized-mime-types'."
982 "String used to delimit header and body.
983 This variable is used by `gnus-article-treat-body-boundary' which can
984 be controlled by `gnus-treat-body-boundary'."
988 string))
992 "Defines the location of the faces database.
993 For information on obtaining this database of pretty pictures, please
994 see http://www.cs.indiana.edu/picons/ftp/index.html"
1003 "Say whether picons are installed on your machine."
1008 installed))
1011 "Function called with a MIME handle as the argument.
1012 This is meant for people who want to do something automatic based
1013 on parts -- for instance, adding Vcard info to a database."
1016 function))
1019 "An alist of MIME types to functions to display them."
1025 "A list of Date header formats to display.
1026 Valid formats are `ut' (universal time), `local' (local time
1027 zone), `english' (readable English), `lapsed' (elapsed time),
1028 `combined-lapsed' (both the original date and the elapsed time),
1029 `original' (the original date header), `iso8601' (ISO8601
1030 format), and `user-defined' (a user-defined format defined by the
1031 `gnus-article-time-format' variable).
1033 You have as many date headers as you want in the article buffer.
1034 Some of these headers are updated automatically. See
1035 `gnus-article-update-date-headers' for details."
1049 "A number that says how often to update the date header (in seconds).
1050 If nil, don't update it at all."
1055 integer))
1058 "Function called with a MIME handle as the argument.
1059 This is meant for people who want to view first matched part.
1060 For `undisplayed-alternative' (default), the first undisplayed
1061 part or alternative part is used. For `undisplayed', the first
1062 undisplayed part is used. For a function, the first part which
1063 the function return t is used. For nil, the first part is
1064 used."
1087 "An alist of actions that run on the MIME attachment."
1093 "Advance to next MIME part when deleting or stripping parts.
1095 When 0, point will be placed on the same part as before. When
1096 positive (negative), move point forward (backwards) this many
1097 parts. When nil, redisplay article."
1103 integer))
1105 ;;;
1106 ;;; The treatment variables
1107 ;;;
1134 "Highlight the signature.
1135 Valid values are nil, t, `head', `first', `last', an integer or a
1136 predicate. See Info node `(gnus)Customizing Articles'."
1143 "Add buttons.
1144 Valid values are nil, t, `head', `first', `last', an integer or a
1145 predicate. See Info node `(gnus)Customizing Articles'."
1152 "Add buttons to the head.
1153 Valid values are nil, t, `head', `first', `last', an integer or a
1154 predicate. See Info node `(gnus)Customizing Articles'."
1161 "Display dates according to the `gnus-article-date-headers' variable.
1162 Valid values are nil, t, `head', `first', `last', an integer or a
1163 predicate. See Info node `(gnus)Customizing Articles'."
1170 "Emphasize text.
1171 Valid values are nil, t, `head', `first', `last', an integer or a
1172 predicate. See Info node `(gnus)Customizing Articles'."
1179 "Remove carriage returns.
1180 Valid values are nil, t, `head', `first', `last', an integer or a
1181 predicate. See Info node `(gnus)Customizing Articles'."
1188 "Remove newlines from within URLs.
1189 Valid values are nil, t, `head', `first', `last', an integer or a
1190 predicate. See Info node `(gnus)Customizing Articles'."
1197 "Remove leading whitespace in headers.
1198 Valid values are nil, t, `head', `first', `last', an integer or a
1199 predicate. See Info node `(gnus)Customizing Articles'."
1206 "Hide headers.
1207 Valid values are nil, t, `head', `first', `last', an integer or a
1208 predicate. See Info node `(gnus)Customizing Articles'."
1214 "Hide boring headers.
1215 Valid values are nil, t, `head', `first', `last', an integer or a
1216 predicate. See Info node `(gnus)Customizing Articles'."
1222 "Hide the signature.
1223 Valid values are nil, t, `head', `first', `last', an integer or a
1224 predicate. See Info node `(gnus)Customizing Articles'."
1230 "Fill the article.
1231 Valid values are nil, t, `head', `first', `last', an integer or a
1232 predicate. See Info node `(gnus)Customizing Articles'."
1238 "Hide cited text.
1239 Valid values are nil, t, `head', `first', `last', an integer or a
1240 predicate. See Info node `(gnus)Customizing Articles'.
1242 See `gnus-article-highlight-citation' for variables used to
1243 control what it hides."
1249 "Hide cited text according to certain conditions.
1250 Valid values are nil, t, `head', `first', `last', an integer or a
1251 predicate. See Info node `(gnus)Customizing Articles'.
1253 See `gnus-cite-hide-percentage' and `gnus-cite-hide-absolute' for
1254 how to control what it hides."
1260 "Strip list identifiers from `gnus-list-identifiers`.
1261 Valid values are nil, t, `head', `first', `last', an integer or a
1262 predicate. See Info node `(gnus)Customizing Articles'."
1269 list-identifier
1270 :variable-document
1271 "Alist of regexps and correspondent identifiers."
1272 :variable-group gnus-article-washing
1273 :parameter-type
1275 :value nil
1277 regexp
1279 :parameter-document
1280 "If non-nil, specify how to remove `identifiers' from articles' subject.
1282 Any symbol is used to look up a regular expression to match the
1283 banner in `gnus-list-identifiers'. A string is used as a regular
1290 "Strip PEM signatures.
1291 Valid values are nil, t, `head', `first', `last', an integer or a
1292 predicate. See Info node `(gnus)Customizing Articles'."
1298 "Strip banners from articles.
1299 The banner to be stripped is specified in the `banner' group parameter.
1300 Valid values are nil, t, `head', `first', `last', an integer or a
1301 predicate. See Info node `(gnus)Customizing Articles'."
1307 "Highlight the headers.
1308 Valid values are nil, t, `head', `first', `last', an integer or a
1309 predicate. See Info node `(gnus)Customizing Articles'."
1316 "Highlight cited text.
1317 Valid values are nil, t, `head', `first', `last', an integer or a
1318 predicate. See Info node `(gnus)Customizing Articles'."
1325 "Strip the X-No-Archive header line from the beginning of the body.
1326 Valid values are nil, t, `head', `first', `last', an integer or a
1327 predicate. See Info node `(gnus)Customizing Articles'."
1334 "Strip trailing blank lines.
1335 Valid values are nil, t, `head', `first', `last', an integer or a
1336 predicate. See Info node `(gnus)Customizing Articles'.
1338 When set to t, it also strips trailing blanks in all MIME parts.
1339 Consider to use `last' instead."
1345 "Strip leading blank lines.
1346 Valid values are nil, t, `head', `first', `last', an integer or a
1347 predicate. See Info node `(gnus)Customizing Articles'.
1349 When set to t, it also strips trailing blanks in all MIME parts."
1355 "Strip multiple blank lines.
1356 Valid values are nil, t, `head', `first', `last', an integer or a
1357 predicate. See Info node `(gnus)Customizing Articles'."
1363 "Unfold folded header lines.
1364 Valid values are nil, t, `head', `first', `last', an integer or a
1365 predicate. See Info node `(gnus)Customizing Articles'."
1372 "If non-nil, allow unfolding headers even if the header is long.
1373 If it is a regexp, only long headers matching this regexp are unfolded.
1374 If it is t, all long headers are unfolded.
1376 This variable has no effect if `gnus-treat-unfold-headers' is nil."
1384 "Fold headers.
1385 Valid values are nil, t, `head', `first', `last', an integer or a
1386 predicate. See Info node `(gnus)Customizing Articles'."
1393 "Fold the Newsgroups and Followup-To headers.
1394 Valid values are nil, t, `head', `first', `last', an integer or a
1395 predicate. See Info node `(gnus)Customizing Articles'."
1402 "Treat overstrike highlighting.
1403 Valid values are nil, t, `head', `first', `last', an integer or a
1404 predicate. See Info node `(gnus)Customizing Articles'."
1411 "Treat ANSI SGR control sequences.
1412 Valid values are nil, t, `head', `first', `last', an integer or a
1413 predicate. See Info node `(gnus)Customizing Articles'."
1429 ;; shell-command-to-string may signal an error, e.g. if
1430 ;; shell-file-name is not found.
1433 "Display X-Face headers.
1434 Valid values are nil and `head'.
1435 See Info node `(gnus)Customizing Articles' and Info node
1436 `(gnus)X-Face' for details."
1441 :type gnus-article-treat-head-custom
1444 symbol
1446 value)
1449 ** gnus-treat-display-xface is an obsolete variable;\
1454 ** gnus-treat-display-xface is an obsolete variable;\
1458 value)))))
1465 "Display Face headers.
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)Face' for details."
1477 "Display smileys.
1478 Valid values are nil, t, `head', `first', `last', an integer or a
1479 predicate. See Info node `(gnus)Customizing Articles' and Info
1480 node `(gnus)Smileys' for details."
1492 "Display picons in the From header.
1493 Valid values are nil, t, `head', `first', `last', an integer or a
1494 predicate. See Info node `(gnus)Customizing Articles' and Info
1495 node `(gnus)Picons' for details."
1508 "Display picons in To and Cc headers.
1509 Valid values are nil, t, `head', `first', `last', an integer or a
1510 predicate. See Info node `(gnus)Customizing Articles' and Info
1511 node `(gnus)Picons' for details."
1524 "Display picons in the Newsgroups and Followup-To headers.
1525 Valid values are nil, t, `head', `first', `last', an integer or a
1526 predicate. See Info node `(gnus)Customizing Articles' and Info
1527 node `(gnus)Picons' for details."
1537 "Display gravatars in the From header.
1538 Valid values are nil, t, `head', `first', `last', an integer or a
1539 predicate. See Info node `(gnus)Customizing Articles' and Info
1540 node `(gnus)Gravatars' for details."
1550 "Display gravatars in To and Cc headers.
1551 Valid values are nil, t, `head', `first', `last', an integer or a
1552 predicate. See Info node `(gnus)Customizing Articles' and Info
1553 node `(gnus)Gravatars' for details."
1564 gnus-treat-mail-picon
1565 gnus-treat-from-picon
1566 gnus-treat-from-gravatar
1567 gnus-treat-mail-gravatar)
1568 ;; If there's much decoration, the user might prefer a boundary.
1569 'head
1570 nil)
1571 "Draw a boundary at the end of the headers.
1572 Valid values are nil and `head'.
1573 See Info node `(gnus)Customizing Articles' for details."
1580 "Capitalize sentence-starting words.
1581 Valid values are nil, t, `head', `first', `last', an integer or a
1582 predicate. See Info node `(gnus)Customizing Articles'."
1589 "Format as HTML.
1590 Valid values are nil, t, `head', `first', `last', an integer or a
1591 predicate. See Info node `(gnus)Customizing Articles'."
1598 "Fill long lines.
1599 Valid values are nil, t, `head', `first', `last', an integer or a
1600 predicate. See Info node `(gnus)Customizing Articles'."
1607 "Verify X-PGP-Sig.
1608 To automatically treat X-PGP-Sig, set it to head.
1609 Valid values are nil, t, `head', `first', `last', an integer or a
1610 predicate. See Info node `(gnus)Customizing Articles'."
1620 ;; Set to nil if more than one protocol added to
1621 ;; gnus-article-encrypt-protocol-alist.
1623 "The protocol used for encrypt articles.
1631 idna-program
1633 "Whether IDNA decoding of headers is used when viewing messages.
1634 This requires GNU Libidn, and by default only enabled if it is found."
1640 "If non-nil, allow scrolling the article buffer even when there no more text."
1646 "Non-nil means inhibit displaying of images inline in the article body."
1652 "Images that have URLs matching this regexp will be blocked.
1653 This can also be a function to be evaluated. If so, it will be
1654 called with the group name as the parameter, and should return a
1655 regexp."
1660 ;;; Internal variables
1699 gnus-article-remove-trailing-blank-lines)
1701 gnus-article-strip-leading-blank-lines)
1703 gnus-article-strip-multiple-blank-lines)
1725 ;; This causes the citation match run O(2^n).
1726 ;; (modify-syntax-entry ?- "w" table)
1729 ;; make M-. in article buffers work for `foo' strings
1732 table)
1733 "Syntax table used in article mode buffers.
1744 ;;; Macros for dealing with the article buffer.
1768 "Go to HEADER, which is a regular expression."
1772 "Set text PROPS on the B to E region, extending `intangible' 1 past B."
1780 "Remove hidden text properties from region between B and E."
1787 "Hide text of TYPE between B and E."
1793 "Unhide text of TYPE between B and E."
1802 "Delete text of TYPE in the current buffer."
1806 ;; Remove MIME buttons associated with multipart/alternative parts.
1814 t))
1825 "Delete all invisible text in the current buffer."
1834 "Give the rank of the string HEADER as given by `gnus-sorted-header-list'."
1842 i))
1845 "Hide unwanted headers and possibly sort them as well."
1847 ;; This function might be inhibited.
1854 ignored visible beg)
1856 ;; `gnus-ignored-headers' and `gnus-visible-headers' may be
1857 ;; group parameters, so we should go to the summary buffer.
1864 gnus-ignored-headers)
1867 gnus-ignored-headers
1870 gnus-visible-headers)
1874 gnus-visible-headers
1878 ;; First we narrow to just the headers.
1880 ;; Hide any "From " lines at the beginning of (mail) articles.
1885 ;; Then treat the rest of the header lines.
1886 ;; Then we use the two regular expressions
1887 ;; `gnus-ignored-headers' and `gnus-visible-headers' to
1888 ;; select which header lines is to remain visible in the
1889 ;; article buffer.
1892 ;; Mark the rank of the header.
1904 ;; We delete the unwanted headers.
1911 "Toggle hiding of headers that aren't very interesting.
1912 If given a negative prefix, always show; if given a positive prefix,
1913 always hide."
1925 ;; Hide empty headers.
1937 ;; Hide boring Newsgroups header.
1943 gnus-newsgroup-name
1955 ;; only one address in To
1957 to-address)))
1968 ;; only one address in To
1970 to-list)))
1981 ;; only one address in CC
1983 to-list)))
1998 from reply-to
2012 ;; If date in `gnus-article-buffer' is localized
2013 ;; (`gnus-treat-date-user-defined'),
2014 ;; `days-between' might fail.
2072 "Make all header lines 40 characters long."
2075 column)
2082 gnus-article-normalized-header-length)
2086 ? )))
2095 ;; Do nothing.
2096 ))
2100 "Translate M****s*** sm*rtq**t*s and other symbols into proper text.
2101 Note that this function guesses whether a character is a sm*rtq**t* or
2102 not, so it should only be used interactively.
2104 Sm*rtq**t*s are M****s***'s unilateral extension to the
2105 iso-8859-1 character map in an attempt to provide more quoting
2107 you're expecting some kind of apostrophe or quotation mark, then
2108 try this wash."
2115 "Translate many Unicode characters into their ASCII equivalents."
2128 replace props)
2138 props)
2142 "Translate all string in the body of the article according to MAP.
2162 "Translate overstrikes into bold text."
2170 ;; We do the boldification/underlining by hiding the
2171 ;; overstrikes and putting the proper text property
2172 ;; on the letters.
2188 "Translate ANSI SGR control sequences into overlays or extents."
2196 "Unfold folded message headers.
2197 Only the headers that fit into the current window width will be
2198 unfolded."
2210 header)))))
2224 "Fold message headers."
2247 "Remove all images from the article buffer."
2258 "Show any images that are in the HTML-rendered article buffer.
2259 This only works if the article in question is HTML."
2271 start end)))))))
2274 "Unfold folded message headers.
2275 Only the headers that fit into the current window width will be
2276 unfolded."
2288 "Value of `truncate-lines' in Gnus Article buffer.
2289 Valid values are nil, t, `head', `first', `last', an integer or a
2290 predicate. See Info node `(gnus)Customizing Articles'."
2293 ;; :link '(custom-manual "(gnus)Customizing Articles")
2297 "Toggle whether to fold or truncate long lines in article the buffer.
2298 If ARG is non-nil and not a number, toggle
2299 `gnus-article-truncate-lines' too. If ARG is a number, truncate
2300 long lines if and only if arg is positive."
2316 ;; In versions of Emacs 22 (CVS) before 2006-05-26,
2317 ;; `toggle-truncate-lines' needs an argument.
2321 "Place a boundary line at the end of the headers."
2340 "Fill lines that are wider than the window width."
2360 "Capitalize the first word in each sentence."
2371 "Remove trailing CRs and then translate remaining CRs into LFs."
2383 "Remove all trailing blank lines from the article."
2402 "Display any Face headers in the header."
2406 ;; When displaying parts, this function can be called several times on
2407 ;; the same article, without any intended toggle semantic (as typing `W
2408 ;; D d' would have). So face deletion must occur only when we come from
2409 ;; an interactive command, that is when the *Article* buffer is
2410 ;; read-only.
2414 face faces)
2423 ;; Check whether this face is censored.
2428 from))))
2450 "Look for an X-Face header and display it if present."
2454 ;; Delete the old process, if any.
2457 ;; See the comment in `article-display-face'.
2459 ;; We have already displayed X-Faces, so we remove them
2460 ;; instead.
2462 ;; Display X-Faces.
2464 x-faces face)
2469 ;; If type `W f', use gnus-original-article-buffer,
2470 ;; otherwise use the current buffer because displaying
2471 ;; RFC822 parts calls this function too.
2477 ;; Check whether this face is censored.
2482 from))))
2486 ;; We display the face.
2488 ;; The command is a lisp function, so we call it.
2491 ;; The command is a string, so we interpret the command
2492 ;; as a, well, command, and fork it off.
2496 "article-x-face" nil shell-file-name
2497 shell-command-switch gnus-article-x-face-command)
2498 nil)
2499 ;; Sending multiple EOFs to xv doesn't work,
2500 ;; so we only do a single external face.
2508 gnus-article-x-face-command
2512 "Decode all MIME-encoded words in the article."
2519 gnus-newsgroup-ignored-charsets)))
2523 "Decode charset-encoded text in the article.
2524 If PROMPT (the prefix), prompt for a coding system to use."
2533 gnus-newsgroup-ignored-charsets))
2534 ct cte ctl charset format)
2557 ;; The text code could have been decoded.
2568 "Remove encoded-word encoding from headers."
2575 gnus-newsgroup-ignored-charsets))
2577 end start)
2596 "Decode group names in Newsgroups, Followup-To and Xref headers."
2600 regexp)
2602 gnus-group-name-charset-group-alist)
2614 ;; XXX how to use data in article buffer?
2618 gnus-newsgroup-name method))
2625 "Decode IDNA strings in RHS in various headers in current buffer.
2626 The following headers are decoded: From:, To:, Cc:, Reply-To:,
2627 Mail-Reply-To: and Mail-Followup-To:."
2646 "Translate a quoted-printable-encoded article.
2647 If FORCE, decode the article whether it is marked as quoted-printable
2648 or not.
2649 If READ-CHARSET, ask for a coding system."
2675 "Translate a base64 article.
2676 If FORCE, decode the article whether it is marked as base64 not.
2677 If READ-CHARSET, ask for a coding system."
2710 "Translate a HZ-encoded article."
2718 "Remove the newlines that some other mailers insert into URLs."
2730 "Format an HTML article."
2743 "List of temporary files created by `gnus-article-browse-html-parts'.
2747 "What to do with temporary files from `gnus-article-browse-html-parts'.
2748 If nil, don't delete temporary files. If it is t, delete them on
2749 exit from the summary buffer. If it is the symbol `file', query
2750 on each file, if it is `ask' ask once when exiting from the
2751 summary buffer."
2759 ;; Cf. mm-postponed-undisplay-list / mm-destroy-postponed-undisplay-list.
2762 "Delete temp-files created by `gnus-article-browse-html-parts'."
2770 "Delete the temporary HTML file? "
2772 files)))
2774 how)))
2780 "Delete temporary HTML file(s) in directory `%s'? "
2788 ;; Also remove file from the list when not deleted or if file doesn't
2789 ;; exist anymore.
2791 gnus-article-browse-html-temp-list)
2794 "Find CID content in HANDLES and save it in a file in DIRECTORY.
2795 Return file name."
2802 ;; Exclude broken handles that `gnus-summary-enter-digest-group'
2803 ;; may create.
2807 cid handle directory))
2816 mailcap-mime-extensions))))
2817 directory))
2823 Recurse into multiparts. The optional HEADER that should be a decoded
2825 ;; Internal function used by `gnus-article-browse-html-article'.
2827 ;; Find and show the html-parts.
2829 ;; If HTML, show it:
2841 nil)))
2853 ;; resolve cid contents
2855 cid-file)
2859 nil t)
2864 content nil)
2869 gnus-article-mime-handles)
2870 cid-dir))
2876 standard-output
2884 ;; Do we need to care for 8.3 filenames?
2886 ;; Add a meta html tag to specify charset and a header.
2897 nil t)
2913 ;; We have to examine charset one by one since
2914 ;; charset specified in parts might be different.
2918 charset)
2927 hcharset nil t)))
2930 coding hcharset)))
2936 nil t))
2942 title coding))
2943 body content)
2949 title charset))
2952 content body)
2953 charset))))
2959 title coding))
2960 body content))
2962 body content)))
2986 content))
3001 ;; FIXME: Warn if there's an <img> tag?
3004 ;; If multipart, recurse
3019 gnus-visible-headers)))
3029 showed))
3033 Inline images embedded in a message using the cid scheme, as they are
3034 generally considered to be safe, will be processed properly.
3035 The message header is added to the beginning of every html part unless
3036 the prefix argument ARG is given.
3038 Warning: Spammers use links to images (using the http scheme) in HTML
3039 articles to verify whether you have read the message. As
3040 `gnus-article-browse-html-article' passes the HTML content to the
3042 use it for mails from trusted senders.
3044 If you always want to display HTML parts in the browser, set
3045 `mm-text-html-renderer' to nil.
3047 This command creates temporary files to pass HTML contents including
3048 images if any to the browser, and deletes them when exiting the group
3049 \(if you want)."
3050 ;; Cf. `mm-w3m-safe-url-regexp'
3055 gnus-visible-headers))
3056 ;; As we insert a <hr>, there's no need for the body boundary.
3070 parts)
3073 ;; If singlepart, enforce a list.
3077 ;; Process the list
3085 "Remove list identifiers from the Subject header.
3086 The `gnus-list-identifiers' variable specifies what to do."
3098 nil t)
3106 "Toggle hiding of any PEM headers and signatures in the current article.
3107 If given a negative prefix, always show; if given a positive prefix,
3108 always hide."
3114 ;; Hide the horrendously ugly "header".
3117 nil t)
3121 end
3126 ;; Hide the trailer as well
3128 nil t)
3133 "Strip the banners specified by the `banner' group parameter and by
3134 `gnus-article-address-banner-alist'."
3143 ;; Note that the From header is decoded here, so it is
3144 ;; required that the *-extract-address-components function
3145 ;; supports non-ASCII text.
3153 from))))
3161 "Strip the banner specified by the argument."
3183 "Translate article using an online translation service."
3198 "Hide the signature in the current article.
3199 If given a negative prefix, always show; if given a positive prefix,
3200 always hide."
3212 "Strip offensive headers from bodies."
3221 "Remove all blank lines from the beginning of the article."
3232 "Narrow the buffer to the head of the message.
3233 Point is left at the beginning of the narrowed-to region."
3237 ;; Absolutely no headers displayed.
3240 ;; Normal headers.
3243 ;; Nothing but headers.
3249 "Place point at the start of the body."
3252 ;; This variable is only bound when dealing with separate
3253 ;; MIME body parts.
3255 t)
3257 t)
3260 nil)))
3263 "Replace consecutive blank lines with one empty line."
3268 ;; First make all blank lines empty.
3274 ;; Then replace multiple empty lines with a single empty line.
3282 "Remove all white space from the beginning of the lines in the article."
3292 "Remove all white space from the end of the lines in the article."
3302 "Strip leading, trailing and multiple blank lines."
3309 "Strip all blank lines."
3319 "Narrow to the signature; return t if a signature is found, else nil."
3323 ;; Check whether we have some limits to what we consider
3324 ;; to be a signature.
3327 limit limited)
3339 limits nil)))
3342 t)))))
3345 "Search the current buffer for the signature separator.
3346 Put point at the beginning of the signature separator."
3355 seps))
3356 t
3358 nil)))
3361 "Return the current prefix arg as a number, or 0 if no prefix."
3367 "Return nil if hiding is necessary.
3368 Arg can be nil or a number. nil and positive means hide, negative
3369 means show, 0 means toggle."
3376 nil)
3379 t)
3384 t)
3385 nil)))))))
3388 "Say whether the current buffer contains hidden text of type TYPE."
3396 'hidden
3397 nil)))
3400 "Show all hidden text of type TYPE.
3401 Originally it is hide instead of DUMMY."
3405 'article-type type
3408 gnus-hidden-properties)))
3421 "Move point to the start of the next header.
3422 If the current header is a continuation header, this can be several
3423 lines forward."
3434 gnus-article-date-headers)
3435 gnus-article-date-headers)
3436 t))
3439 "Convert DATE date to TYPE in the current article.
3440 The default type is `ut'. See `gnus-article-date-headers' for
3441 possible values."
3448 pos date bface eface)
3493 visible-date)
3507 type)))
3517 ;; Do highlighting.
3529 "Return a DATE line of TYPE."
3531 combined-lapsed))
3536 ;; Convert to the local timezone.
3539 ;; Convert to Universal Time.
3553 ;; Get the original date from the article.
3557 date)))
3558 ;; Let the user define the format.
3562 gnus-article-time-format)
3564 gnus-article-time-format)))
3568 ;; ISO 8601.
3572 "Date: "
3577 ;; Do a lapsed format.
3580 ;; A combined date/lapsed format.
3584 lapsed-string)
3586 time
3596 date-string)))
3597 ;; Display the date in proper English
3601 "Date: the "
3610 " of "
3612 " "
3614 " at "
3616 ":"
3622 ;; If the date is seriously mangled, the timezone functions are
3623 ;; liable to bug out, so we ignore all errors.
3631 num prev)
3641 ;; This is a bit convoluted, but basically we go
3642 ;; through the time units for years, weeks, etc,
3643 ;; and divide things to see whether that results
3644 ;; in positive answers.
3649 ;; The (remaining) seconds are too few to
3650 ;; be divided into this time unit.
3651 ""
3652 ;; It's big enough, so we output it.
3662 ;; If dates are odd, then it might appear like the
3663 ;; article was sent in the future.
3665 " ago"
3669 "Convert the current article date to the local timezone."
3674 "Convert the current article date to something that is proper English."
3679 "Convert the current article date to what it was originally.
3680 This is only useful if you have used some other date conversion
3681 function and want to see what the date was before converting."
3686 "Convert the current article date to time lapsed since it was sent."
3691 "Convert the current article date to time lapsed since it was sent."
3696 "Function to be run from a timer to update the lapsed time line."
3708 type next end)
3738 "Start a timer to update the Date headers in the article buffers.
3739 The numerical prefix says how frequently (in seconds) the function
3740 is to run."
3749 "Stop the Date timer."
3756 "Convert the current article date to the user-defined format.
3757 This format is defined by the `gnus-article-time-format' variable."
3762 "Convert the current article date to ISO8601."
3767 "Save the original date as a text property and evaluate FORMS."
3776 nil t))
3782 ,@forms
3787 ;; (defun article-show-all ()
3788 ;; "Show all hidden text in the article buffer."
3789 ;; (interactive)
3790 ;; (save-excursion
3791 ;; (let ((inhibit-read-only t))
3792 ;; (gnus-article-unhide-text (point-min) (point-max)))))
3795 "Remove excessive whitespace from all headers."
3806 "Emphasize text according to `gnus-emphasis-alist'."
3813 gnus-article-emphasis-alist)
3815 gnus-emphasis-alist))
3818 gnus-hidden-properties))
3819 regexp elem beg invisible visible face)
3840 "Setup newsgroup emphasis alist."
3852 highlight)
3857 gnus-emphasis-alist)))))
3862 ;;; Saving functions.
3865 "Save the currently selected article."
3868 ;; Remove headers according to `gnus-saved-headers' or the value
3869 ;; of the `:headers' property that the saver function might have.
3872 gnus-saved-headers gnus-visible-headers))
3873 ;; Ignore group parameter. See `article-hide-headers'.
3880 ;; !!! Magic! The saving functions all save
3881 ;; `gnus-save-article-buffer' (or so they think), but we
3882 ;; bind that variable to our save-buffer.
3897 function group headers variable
3898 dir-var)
3901 result)
3906 default-name)
3908 default-name)
3921 gnus-number-of-articles-to-be-saved)
3924 ;; Let the split methods have their say.
3926 ;; No split name was found.
3932 default-name))
3933 ;; A single group name is returned.
3942 default-name))
3943 ;; A single split name was found
3947 gnus-article-save-directory))
3954 dir name)))
3955 ;; A list of splits was found.
3965 gnus-article-save-directory
3967 gnus-article-save-directory)))
3969 ;; Create the directory.
3971 ;; If we have read a directory, we append the default file name.
3974 default-name)
3976 ;; Possibly translate some characters.
3983 result))
3993 "If GROUP is an nndoc group, return the name of the parent group."
3998 "Append this article to Rmail file.
3999 Optional argument FILENAME specifies file name.
4000 Directory to save to is default to `gnus-article-save-directory'."
4002 "Save %s in rmail file" filename
4003 gnus-rmail-save-name gnus-newsgroup-name
4009 ;; Note that unlike gnus-summary-save-in-mail, there is no
4010 ;; check to see if filename is Babyl. Rmail in Emacs 23 does
4011 ;; not use Babyl.
4013 filename)
4016 "Append this article to Unix mail file.
4017 Optional argument FILENAME specifies file name.
4018 Directory to save to is default to `gnus-article-save-directory'."
4020 "Save %s in Unix mail file" filename
4021 gnus-mail-save-name gnus-newsgroup-name
4032 filename)
4037 "Append this article to file.
4038 Optional argument FILENAME specifies file name.
4039 Directory to save to is default to `gnus-article-save-directory'."
4041 "Save %s in file" filename
4042 gnus-file-save-name gnus-newsgroup-name
4052 filename)
4058 "Write this article to a file, overwriting it if the file exists.
4059 Optional argument FILENAME specifies file name.
4060 The directory to save in defaults to `gnus-article-save-directory'."
4062 "Save %s in file" filename
4063 gnus-file-save-name gnus-newsgroup-name
4069 "Append this article body to a file.
4070 Optional argument FILENAME specifies file name.
4071 The directory to save in defaults to `gnus-article-save-directory'."
4073 "Save %s body in file" filename
4074 gnus-file-save-name gnus-newsgroup-name
4086 filename)
4092 "Write this article body to a file, overwriting it if the file exists.
4093 Optional argument FILENAME specifies file name.
4094 The directory to save in defaults to `gnus-article-save-directory'."
4096 "Save %s body in file" filename
4097 gnus-file-save-name gnus-newsgroup-name
4104 "Pipe this article to subprocess COMMAND.
4105 Valid values for COMMAND include:
4106 a string
4107 The executable command name and possibly arguments.
4108 nil
4109 You will be prompted for the command in the minibuffer.
4110 the symbol `default'
4111 It will be replaced with the command which the variable
4112 `gnus-summary-pipe-output-default-command' holds or the command
4113 last used for saving.
4114 Non-nil value for RAW overrides `:decode' and `:headers' properties
4115 and the raw article including all headers will be piped."
4119 save-buffer default)
4127 gnus-article-buffer
4128 gnus-original-article-buffer)
4131 ;; Remove unwanted headers.
4138 gnus-saved-headers gnus-visible-headers))
4144 gnus-last-shell-command))
4148 default
4150 default))))
4163 "Pipe this article to muttprint."
4166 "Print using command: " gnus-summary-muttprint-program
4167 nil gnus-summary-muttprint-program)))
4169 gnus-summary-pipe-output-default-command))
4173 ;;; Article file names when saving.
4176 "Capitalize NEWSGROUP name."
4182 "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
4183 If variable `gnus-use-long-file-name' is non-nil, it is ~/News/News.group/num.
4184 Otherwise, it is like ~/News/news/group/num."
4191 gnus-article-save-directory)))
4196 default
4200 "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
4201 If variable `gnus-use-long-file-name' is non-nil, it is
4202 ~/News/news.group/num. Otherwise, it is like ~/News/news/group/num."
4206 newsgroup
4209 gnus-article-save-directory)))
4214 default
4218 "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
4219 If variable `gnus-use-long-file-name' is non-nil, it is
4220 ~/News/news.group. Otherwise, it is like ~/News/news/group/news."
4224 newsgroup
4227 default-directory))
4228 gnus-article-save-directory)))
4231 "Generate file name from sender."
4237 gnus-article-save-directory)))
4240 "Verify X-PGP-Sig."
4241 ;; <ftp://ftp.isc.org/pub/pgpcontrol/FORMAT>
4246 items info headers)
4248 mml2015-use
4256 ;; Don't verify multiple headers.
4306 ;; Do highlighting.
4317 "Verify Cancel-Lock header."
4341 article-verify-x-pgp-sig
4342 article-verify-cancel-lock
4343 article-hide-boring-headers
4344 article-treat-overstrike
4345 article-treat-ansi-sequences
4346 article-fill-long-lines
4347 article-capitalize-sentences
4348 article-remove-cr
4349 article-remove-leading-whitespace
4350 article-display-x-face
4351 article-display-face
4352 article-de-quoted-unreadable
4353 article-de-base64-unreadable
4354 article-decode-HZ
4355 article-wash-html
4356 article-unsplit-urls
4357 article-hide-list-identifiers
4358 article-strip-banner
4359 article-babel
4360 article-hide-pem
4361 article-hide-signature
4362 article-strip-headers-in-body
4363 article-remove-trailing-blank-lines
4364 article-strip-leading-blank-lines
4365 article-strip-multiple-blank-lines
4366 article-strip-leading-space
4367 article-strip-trailing-space
4368 article-strip-blank-lines
4369 article-strip-all-blank-lines
4370 article-date-local
4371 article-date-english
4372 article-date-iso8601
4373 article-date-original
4374 article-treat-date
4375 article-date-ut
4376 article-decode-mime-words
4377 article-decode-charset
4378 article-decode-encoded-words
4379 article-date-user
4380 article-date-lapsed
4381 article-date-combined-lapsed
4382 article-emphasize
4383 article-treat-dumbquotes
4384 article-treat-non-ascii
4385 article-normalize-headers
4386 ;;(article-show-all . gnus-article-show-all-headers)
4387 )))
4388 \f
4389 ;;;
4390 ;;; Gnus article mode
4391 ;;;
4398 " " gnus-article-goto-next-page
4401 [delete] gnus-article-goto-prev-page
4402 "\C-c^" gnus-article-refer-article
4403 "h" gnus-article-show-summary
4404 "s" gnus-article-show-summary
4405 "\C-c\C-m" gnus-article-mail
4406 "?" gnus-article-describe-briefly
4407 "<" beginning-of-buffer
4408 ">" end-of-buffer
4409 "\C-c\C-i" gnus-info-find-node
4410 "\C-c\C-b" gnus-bug
4411 "R" gnus-article-reply-with-original
4412 "F" gnus-article-followup-with-original
4413 "\C-hk" gnus-article-describe-key
4414 "\C-hc" gnus-article-describe-key-briefly
4415 "\C-hb" gnus-article-describe-bindings
4417 "e" gnus-article-read-summary-keys
4418 "\C-d" gnus-article-read-summary-keys
4419 "\M-*" gnus-article-read-summary-keys
4420 "\M-#" gnus-article-read-summary-keys
4421 "\M-^" gnus-article-read-summary-keys
4422 "\M-g" gnus-article-read-summary-keys)
4424 (substitute-key-definition
4425 'undefined 'gnus-article-read-summary-keys gnus-article-mode-map)
4427 (gnus-define-keys (gnus-article-send-map "S" gnus-article-mode-map)
4428 "W" gnus-article-wide-reply-with-original)
4429 (if (featurep 'xemacs)
4430 (set-keymap-default-binding gnus-article-send-map
4431 'gnus-article-read-summary-send-keys)
4432 (define-key gnus-article-send-map [t] 'gnus-article-read-summary-send-keys))
4434 (defun gnus-article-make-menu-bar ()
4435 (unless (boundp 'gnus-article-commands-menu)
4436 (gnus-summary-make-menu-bar))
4437 (unless (boundp 'gnus-article-article-menu)
4438 (easy-menu-define
4439 gnus-article-article-menu gnus-article-mode-map ""
4440 '("Article"
4441 ["Scroll forwards" gnus-article-goto-next-page t]
4442 ["Scroll backwards" gnus-article-goto-prev-page t]
4443 ["Show summary" gnus-article-show-summary t]
4444 ["Fetch Message-ID at point" gnus-article-refer-article t]
4445 ["Mail to address at point" gnus-article-mail t]
4446 ["Send a bug report" gnus-bug t]))
4448 (easy-menu-define
4449 gnus-article-treatment-menu gnus-article-mode-map ""
4450 ;; Fixme: this should use :active (and maybe :visible).
4451 '("Treatment"
4452 ["Hide headers" gnus-article-hide-headers t]
4453 ["Hide signature" gnus-article-hide-signature t]
4454 ["Hide citation" gnus-article-hide-citation t]
4455 ["Treat overstrike" gnus-article-treat-overstrike t]
4456 ["Treat ANSI sequences" gnus-article-treat-ansi-sequences t]
4457 ["Remove carriage return" gnus-article-remove-cr t]
4458 ["Remove leading whitespace" gnus-article-remove-leading-whitespace t]
4459 ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t]
4460 ["Remove base64" gnus-article-de-base64-unreadable t]
4461 ["Treat html" gnus-article-wash-html t]
4462 ["Remove newlines from within URLs" gnus-article-unsplit-urls t]
4463 ["Decode HZ" gnus-article-decode-HZ t]))
4465 ;; Note "Commands" menu is defined in gnus-sum.el for consistency
4467 ;; Note "Post" menu is defined in gnus-sum.el for consistency
4469 (gnus-run-hooks 'gnus-article-menu-hook)))
4471 (defvar bookmark-make-record-function)
4472 (defvar shr-put-image-function)
4474 (define-derived-mode gnus-article-mode fundamental-mode "Article"
4475 "Major mode for displaying an article.
4477 All normal editing commands are switched off.
4479 The following commands are available in addition to all summary mode
4480 commands:
4489 (gnus-simplify-mode-line)
4490 (make-local-variable 'minor-mode-alist)
4491 (when (gnus-visual-p 'article-menu 'menu)
4492 (gnus-article-make-menu-bar)
4493 (when gnus-summary-tool-bar-map
4494 (set (make-local-variable 'tool-bar-map) gnus-summary-tool-bar-map)))
4495 (gnus-update-format-specifications nil 'article-mode)
4496 (set (make-local-variable 'page-delimiter) gnus-page-delimiter)
4497 (set (make-local-variable 'gnus-page-broken) nil)
4498 (make-local-variable 'gnus-article-current-summary)
4499 (make-local-variable 'gnus-article-mime-handles)
4500 (make-local-variable 'gnus-article-decoded-p)
4501 (make-local-variable 'gnus-article-mime-handle-alist)
4502 (make-local-variable 'gnus-article-wash-types)
4503 (make-local-variable 'gnus-article-image-alist)
4504 (make-local-variable 'gnus-article-charset)
4505 (make-local-variable 'gnus-article-ignored-charsets)
4506 (set (make-local-variable 'bookmark-make-record-function)
4507 'gnus-summary-bookmark-make-record)
4508 ;; Prevent Emacs 22 from displaying non-break space with `nobreak-space'
4509 ;; face.
4510 (set (make-local-variable 'nobreak-char-display) nil)
4511 ;; Enable `gnus-article-remove-images' to delete images shr.el renders.
4512 (set (make-local-variable 'shr-put-image-function) 'gnus-shr-put-image)
4513 (setq cursor-in-non-selected-windows nil)
4514 (gnus-set-default-directory)
4515 (buffer-disable-undo)
4516 (setq buffer-read-only t
4517 show-trailing-whitespace nil)
4518 (mm-enable-multibyte))
4520 (defun gnus-article-setup-buffer ()
4521 "Initialize the article buffer."
4522 (let* ((name (if gnus-single-article-buffer "*Article*"
4523 (concat "*Article "
4524 (gnus-group-decoded-name gnus-newsgroup-name)
4525 "*")))
4526 (original
4528 (concat " *Original Article"
4529 (substring name (match-end 0))))))
4530 (setq gnus-article-buffer name)
4531 (setq gnus-original-article-buffer original)
4532 (setq gnus-article-mime-handle-alist nil)
4533 (with-current-buffer gnus-summary-buffer
4534 ;; This might be a variable local to the summary buffer.
4535 (unless gnus-single-article-buffer
4536 (setq gnus-article-buffer name)
4537 (setq gnus-original-article-buffer original)
4538 (gnus-set-global-variables)))
4539 (gnus-article-setup-highlight-words)
4540 ;; Init original article buffer.
4541 (with-current-buffer (gnus-get-buffer-create gnus-original-article-buffer)
4542 (mm-enable-multibyte)
4543 (setq major-mode 'gnus-original-article-mode)
4544 (make-local-variable 'gnus-original-article))
4545 (if (and (get-buffer name)
4546 (with-current-buffer name
4547 (if gnus-article-edit-mode
4548 (if (y-or-n-p "Article mode edit in progress; discard? ")
4549 (progn
4550 (set-buffer-modified-p nil)
4551 (gnus-kill-buffer name)
4552 (message "")
4553 nil)
4554 (error "Action aborted"))
4555 t)))
4556 (let ((summary gnus-summary-buffer))
4557 (with-current-buffer name
4558 (set (make-local-variable 'gnus-article-edit-mode) nil)
4559 (gnus-article-stop-animations)
4560 (when gnus-article-mime-handles
4561 (mm-destroy-parts gnus-article-mime-handles)
4562 (setq gnus-article-mime-handles nil))
4563 ;; Set it to nil in article-buffer!
4564 (setq gnus-article-mime-handle-alist nil)
4565 (buffer-disable-undo)
4566 (setq buffer-read-only t)
4567 (unless (derived-mode-p 'gnus-article-mode)
4568 (gnus-article-mode))
4569 (set (make-local-variable 'gnus-summary-buffer) summary)
4570 (setq truncate-lines gnus-article-truncate-lines)
4571 (current-buffer)))
4572 (let ((summary gnus-summary-buffer))
4573 (with-current-buffer (gnus-get-buffer-create name)
4574 (gnus-article-mode)
4575 (setq truncate-lines gnus-article-truncate-lines)
4576 (set (make-local-variable 'gnus-summary-buffer) summary)
4577 (gnus-summary-set-local-parameters gnus-newsgroup-name)
4578 (when article-lapsed-timer
4579 (gnus-stop-date-timer))
4580 (when gnus-article-update-date-headers
4581 (gnus-start-date-timer gnus-article-update-date-headers))
4582 (current-buffer))))))
4584 (defun gnus-article-stop-animations ()
4585 (dolist (timer (and (boundp 'timer-list)
4586 timer-list))
4587 (when (eq (gnus-timer--function timer) 'image-animate-timeout)
4588 (cancel-timer timer))))
4590 (defun gnus-stop-downloads ()
4591 (when (boundp 'url-queue)
4592 (set (intern "url-queue" obarray) nil)))
4594 ;; Set article window start at LINE, where LINE is the number of lines
4595 ;; from the head of the article.
4596 (defun gnus-article-set-window-start (&optional line)
4597 (let ((article-window (gnus-get-buffer-window gnus-article-buffer t)))
4598 (when article-window
4599 (set-window-start
4600 article-window
4601 (with-current-buffer gnus-article-buffer
4602 (goto-char (point-min))
4603 (if (not line)
4604 (point-min)
4605 (gnus-message 6 "Moved to bookmark")
4607 (forward-line line)
4608 (point)))))))
4610 (defun gnus-article-prepare (article &optional all-headers header)
4611 "Prepare ARTICLE in article mode buffer.
4612 ARTICLE should either be an article number or a Message-ID.
4613 If ARTICLE is an id, HEADER should be the article headers.
4614 If ALL-HEADERS is non-nil, no headers are hidden."
4615 (save-excursion
4616 ;; Make sure we start in a summary buffer.
4617 (unless (derived-mode-p 'gnus-summary-mode)
4618 (set-buffer gnus-summary-buffer))
4619 (setq gnus-summary-buffer (current-buffer))
4620 (let* ((gnus-article (if header (mail-header-number header) article))
4621 (summary-buffer (current-buffer))
4622 (gnus-tmp-internal-hook gnus-article-internal-prepare-hook)
4623 (group gnus-newsgroup-name)
4624 result)
4625 (save-excursion
4626 (gnus-article-setup-buffer)
4627 (set-buffer gnus-article-buffer)
4628 ;; Deactivate active regions.
4629 (when (and (boundp 'transient-mark-mode)
4630 transient-mark-mode)
4631 (setq mark-active nil))
4632 (if (not (setq result (let ((inhibit-read-only t))
4633 (gnus-request-article-this-buffer
4634 article group))))
4635 ;; There is no such article.
4636 (save-excursion
4637 (when (and (numberp article)
4638 (not (memq article gnus-newsgroup-sparse)))
4639 (setq gnus-article-current
4640 (cons gnus-newsgroup-name article))
4641 (set-buffer gnus-summary-buffer)
4642 (setq gnus-current-article article)
4643 (if (and (memq article gnus-newsgroup-undownloaded)
4644 (not (gnus-online (gnus-find-method-for-group
4645 gnus-newsgroup-name))))
4646 (progn
4647 (gnus-summary-set-agent-mark article)
4648 (message "Message marked for downloading"))
4649 (gnus-summary-mark-article article gnus-canceled-mark)
4650 (unless (memq article gnus-newsgroup-sparse)
4651 (gnus-error 1 "No such article (may have expired or been canceled)")))))
4652 (if (or (eq result 'pseudo)
4653 (eq result 'nneething))
4654 (progn
4655 (with-current-buffer summary-buffer
4656 (push article gnus-newsgroup-history)
4657 (setq gnus-last-article gnus-current-article
4658 gnus-current-article 0
4659 gnus-current-headers nil
4660 gnus-article-current nil)
4661 (if (eq result 'nneething)
4662 (gnus-configure-windows 'summary)
4663 (gnus-configure-windows 'article))
4664 (gnus-set-global-variables))
4665 (let ((gnus-article-mime-handle-alist-1
4666 gnus-article-mime-handle-alist))
4667 (gnus-set-mode-line 'article)))
4668 ;; The result from the `request' was an actual article -
4669 ;; or at least some text that is now displayed in the
4670 ;; article buffer.
4671 (when (and (numberp article)
4672 (not (eq article gnus-current-article)))
4673 ;; Seems like a new article has been selected.
4674 ;; `gnus-current-article' must be an article number.
4675 (with-current-buffer summary-buffer
4676 (push article gnus-newsgroup-history)
4677 (setq gnus-last-article gnus-current-article
4678 gnus-current-article article
4679 gnus-current-headers
4680 (gnus-summary-article-header gnus-current-article)
4681 gnus-article-current
4682 (cons gnus-newsgroup-name gnus-current-article))
4683 (unless (vectorp gnus-current-headers)
4684 (setq gnus-current-headers nil))
4685 (gnus-summary-goto-subject gnus-current-article)
4686 (when (gnus-summary-show-thread)
4687 ;; If the summary buffer really was folded, the
4688 ;; previous goto may not actually have gone to
4689 ;; the right article, but the thread root instead.
4690 ;; So we go again.
4691 (gnus-summary-goto-subject gnus-current-article))
4692 (gnus-run-hooks 'gnus-mark-article-hook)
4693 (gnus-set-mode-line 'summary)
4694 (when (gnus-visual-p 'article-highlight 'highlight)
4695 (gnus-run-hooks 'gnus-visual-mark-article-hook))
4696 ;; Set the global newsgroup variables here.
4697 (gnus-set-global-variables)
4698 (setq gnus-have-all-headers
4699 (or all-headers gnus-show-all-headers))))
4700 (save-excursion
4701 (gnus-configure-windows 'article))
4702 (when (or (numberp article)
4703 (stringp article))
4704 (gnus-article-prepare-display)
4705 ;; Do page break.
4706 (goto-char (point-min))
4707 (when gnus-break-pages
4708 (gnus-narrow-to-page)))
4709 (let ((gnus-article-mime-handle-alist-1
4710 gnus-article-mime-handle-alist))
4711 (gnus-set-mode-line 'article))
4712 (article-goto-body)
4713 (unless (bobp)
4714 (forward-line -1))
4715 (set-window-point (get-buffer-window (current-buffer)) (point))
4716 (gnus-configure-windows 'article)
4717 (gnus-run-hooks 'gnus-article-prepare-hook)
4718 t))))))
4720 ;;;###autoload
4721 (defun gnus-article-prepare-display ()
4722 "Make the current buffer look like a nice article."
4723 ;; Hooks for getting information from the article.
4724 ;; This hook must be called before being narrowed.
4725 (let ((gnus-article-buffer (current-buffer))
4726 buffer-read-only
4727 (inhibit-read-only t))
4728 (unless (derived-mode-p 'gnus-article-mode)
4729 (gnus-article-mode))
4730 (setq buffer-read-only nil
4731 gnus-article-wash-types nil
4732 gnus-article-image-alist nil)
4733 (gnus-run-hooks 'gnus-tmp-internal-hook)
4734 (when gnus-display-mime-function
4735 (funcall gnus-display-mime-function))
4736 ;; Add attachment buttons to the header.
4737 (when gnus-mime-display-attachment-buttons-in-header
4738 (gnus-mime-buttonize-attachments-in-header))))
4740 ;;;
4741 ;;; Gnus Sticky Article Mode
4742 ;;;
4744 (define-derived-mode gnus-sticky-article-mode gnus-article-mode "StickyArticle"
4745 "Mode for sticky articles."
4746 ;; Release bindings that won't work.
4747 (substitute-key-definition 'gnus-article-read-summary-keys 'undefined
4748 gnus-sticky-article-mode-map)
4749 (substitute-key-definition 'gnus-article-refer-article 'undefined
4750 gnus-sticky-article-mode-map)
4751 (dolist (k '("e" "h" "s" "F" "R"))
4752 (define-key gnus-sticky-article-mode-map k nil))
4753 (define-key gnus-sticky-article-mode-map "k" 'gnus-kill-sticky-article-buffer)
4754 (define-key gnus-sticky-article-mode-map "q" 'bury-buffer)
4755 (define-key gnus-sticky-article-mode-map "\C-hc" 'describe-key-briefly)
4756 (define-key gnus-sticky-article-mode-map "\C-hk" 'describe-key))
4758 (defun gnus-sticky-article (arg)
4759 "Make the current article sticky.
4760 If a prefix ARG is given, ask for a name for this sticky article buffer."
4761 (interactive "P")
4762 (gnus-summary-show-thread)
4763 (gnus-summary-select-article nil nil 'pseudo)
4764 (let (new-art-buf-name)
4765 (gnus-eval-in-buffer-window gnus-article-buffer
4766 (setq new-art-buf-name
4767 (concat
4768 "*Sticky Article: "
4769 (if arg
4770 (read-from-minibuffer "Sticky article buffer name: ")
4771 (gnus-with-article-headers
4772 (gnus-article-goto-header "subject")
4773 (setq new-art-buf-name
4774 (buffer-substring-no-properties
4775 (line-beginning-position) (line-end-position)))
4776 (goto-char (point-min))
4777 (gnus-article-goto-header "from")
4778 (setq new-art-buf-name
4779 (concat
4780 new-art-buf-name ", "
4781 (buffer-substring-no-properties
4782 (line-beginning-position) (line-end-position))))
4783 (goto-char (point-min))
4784 (gnus-article-goto-header "date")
4785 (setq new-art-buf-name
4786 (concat
4787 new-art-buf-name ", "
4788 (buffer-substring-no-properties
4789 (line-beginning-position) (line-end-position))))))
4790 "*"))
4791 (if (and (gnus-buffer-live-p new-art-buf-name)
4792 (with-current-buffer new-art-buf-name
4793 (derived-mode-p 'gnus-sticky-article-mode)))
4794 (switch-to-buffer new-art-buf-name)
4795 (setq new-art-buf-name (rename-buffer new-art-buf-name t)))
4796 (gnus-sticky-article-mode))
4797 (setq gnus-article-buffer new-art-buf-name))
4798 (gnus-summary-recenter)
4799 (gnus-summary-position-point))
4801 (defun gnus-kill-sticky-article-buffer (&optional buffer)
4802 "Kill the given sticky article BUFFER.
4803 If none is given, assume the current buffer and kill it if it has
4804 `gnus-sticky-article-mode'."
4805 (interactive)
4806 (unless buffer
4807 (setq buffer (current-buffer)))
4808 (with-current-buffer buffer
4809 (when (derived-mode-p 'gnus-sticky-article-mode)
4810 (gnus-kill-buffer buffer))))
4812 (defun gnus-kill-sticky-article-buffers (arg)
4813 "Kill all sticky article buffers.
4814 If a prefix ARG is given, ask for confirmation."
4815 (interactive "P")
4816 (dolist (buf (gnus-buffers))
4817 (with-current-buffer buf
4818 (when (derived-mode-p 'gnus-sticky-article-mode)
4819 (if (not arg)
4820 (gnus-kill-buffer buf)
4821 (when (yes-or-no-p (concat "Kill buffer " (buffer-name buf) "? "))
4822 (gnus-kill-buffer buf)))))))
4824 ;;;
4825 ;;; Gnus MIME viewing functions
4826 ;;;
4829 "Format of the MIME buttons.
4831 Valid specifiers include:
4832 %t The MIME type
4833 %T MIME type, along with additional info
4834 %n The `name' parameter
4835 %d The description, if any
4836 %l The length of the encoded part
4837 %p The part identifier number
4838 %e Dots if the part isn't displayed
4840 General format specifiers can also be used. See Info node
4841 `(gnus)Formatting Variables'.")
4843 (defvar gnus-mime-button-line-format-alist
4844 '((?t gnus-tmp-type ?s)
4845 (?T gnus-tmp-type-long ?s)
4846 (?n gnus-tmp-name ?s)
4847 (?d gnus-tmp-description ?s)
4848 (?p gnus-tmp-id ?s)
4849 (?l gnus-tmp-length ?d)
4850 (?e gnus-tmp-dots ?s)))
4852 (defvar gnus-mime-button-commands
4854 (gnus-mime-view-part "v" "View Interactively...")
4855 (gnus-mime-view-part-as-type "t" "View As Type...")
4856 (gnus-mime-view-part-as-charset "C" "View As charset...")
4857 (gnus-mime-save-part "o" "Save...")
4858 (gnus-mime-save-part-and-strip "\C-o" "Save and Strip")
4859 (gnus-mime-replace-part "r" "Replace part")
4860 (gnus-mime-delete-part "d" "Delete part")
4861 (gnus-mime-copy-part "c" "View As Text, In Other Buffer")
4862 (gnus-mime-inline-part "i" "View As Text, In This Buffer")
4863 (gnus-mime-view-part-internally "E" "View Internally") ;; Why `E'?
4864 (gnus-mime-view-part-externally "e" "View Externally")
4865 (gnus-mime-print-part "p" "Print")
4866 (gnus-mime-pipe-part "|" "Pipe To Command...")
4867 (gnus-mime-action-on-part "." "Take action on the part...")))
4869 (defun gnus-article-mime-part-status ()
4870 (if gnus-article-mime-handle-alist-1
4871 (if (eq 1 (length gnus-article-mime-handle-alist-1))
4872 " (1 part)"
4873 (format " (%d parts)" (length gnus-article-mime-handle-alist-1)))
4874 ""))
4876 (defvar gnus-mime-button-map
4877 (let ((map (make-sparse-keymap)))
4878 (define-key map gnus-mouse-2 'gnus-article-push-button)
4879 (define-key map gnus-down-mouse-3 'gnus-mime-button-menu)
4880 (dolist (c gnus-mime-button-commands)
4881 (define-key map (cadr c) (car c)))
4882 map))
4884 (easy-menu-define
4885 gnus-mime-button-menu gnus-mime-button-map "MIME button menu."
4886 `("MIME Part"
4887 ,@(mapcar (lambda (c)
4888 (vector (caddr c) (car c) :active t))
4889 gnus-mime-button-commands)))
4891 (defvar gnus-url-button-commands
4892 '((gnus-article-copy-string "u" "Copy URL to kill ring")))
4894 (defvar gnus-url-button-map
4895 (let ((map (make-sparse-keymap)))
4896 (dolist (c gnus-url-button-commands)
4897 (define-key map (cadr c) (car c)))
4898 map))
4900 (easy-menu-define
4901 gnus-url-button-menu gnus-url-button-map "URL button menu."
4902 `("Url Button"
4903 ,@(mapcar (lambda (c)
4904 (vector (caddr c) (car c) :active t))
4905 gnus-url-button-commands)))
4907 (defmacro gnus-bind-safe-url-regexp (&rest body)
4908 "Bind `mm-w3m-safe-url-regexp' according to `gnus-safe-html-newsgroups'."
4909 `(let ((mm-w3m-safe-url-regexp
4910 (let ((group (if (and (derived-mode-p 'gnus-article-mode)
4911 (gnus-buffer-live-p
4912 gnus-article-current-summary))
4913 (with-current-buffer gnus-article-current-summary
4914 gnus-newsgroup-name)
4915 gnus-newsgroup-name)))
4916 (if (cond ((not group)
4917 ;; Maybe we're in a mml-preview buffer
4918 ;; and no group is selected.
4919 t)
4920 ((stringp gnus-safe-html-newsgroups)
4921 (string-match gnus-safe-html-newsgroups group))
4922 ((consp gnus-safe-html-newsgroups)
4923 (member group gnus-safe-html-newsgroups)))
4924 nil
4925 mm-w3m-safe-url-regexp))))
4926 ,@body))
4928 (defun gnus-mime-button-menu (event prefix)
4929 "Construct a context-sensitive menu of MIME commands."
4931 (save-window-excursion
4932 (let ((pos (event-start event)))
4933 (select-window (posn-window pos))
4934 (goto-char (posn-point pos))
4935 (gnus-article-check-buffer)
4936 (popup-menu gnus-mime-button-menu nil prefix))))
4938 (defun gnus-mime-view-all-parts (&optional handles)
4939 "View all the MIME parts."
4940 (interactive)
4941 (with-current-buffer gnus-article-buffer
4942 (let ((handles (or handles gnus-article-mime-handles))
4943 (mail-parse-charset gnus-newsgroup-charset)
4944 (mail-parse-ignored-charsets
4945 (with-current-buffer gnus-summary-buffer
4946 gnus-newsgroup-ignored-charsets)))
4947 (when handles
4948 (mm-remove-parts handles)
4949 (goto-char (point-min))
4951 (let ((inhibit-read-only t))
4952 (delete-region (point) (point-max))
4953 (gnus-bind-safe-url-regexp (mm-display-parts handles)))))))
4955 (defun gnus-article-jump-to-part (n)
4956 "Jump to MIME part N."
4957 (interactive "P")
4958 (let ((parts (with-current-buffer gnus-article-buffer
4959 (length gnus-article-mime-handle-alist))))
4960 (when (zerop parts)
4961 (error "No such part"))
4962 (pop-to-buffer gnus-article-buffer)
4963 (or n
4964 (setq n (if (= parts 1)
4965 1
4966 (read-number (format "Jump to part (1..%s): " parts)))))
4967 (unless (and (integerp n) (<= n parts) (>= n 1))
4968 (setq n
4969 (progn
4970 (gnus-message 7 "Invalid part `%s', using %s instead."
4971 n parts)
4972 parts)))
4973 (gnus-message 9 "Jumping to part %s." n)
4974 (cond ((>= gnus-auto-select-part 1)
4975 (while (and (<= n parts)
4976 (not (gnus-article-goto-part n)))
4977 (setq n (1+ n))))
4978 ((< gnus-auto-select-part 0)
4979 (while (and (>= n 1)
4980 (not (gnus-article-goto-part n)))
4981 (setq n (1- n))))
4982 (t
4983 (gnus-article-goto-part n)))))
4985 (defvar gnus-mime-buttonized-part-id nil
4986 "ID of a mime part that should be buttonized.
4987 `gnus-mime-save-part-and-strip' and `gnus-mime-delete-part' bind it.")
4989 (eval-when-compile
4990 (defsubst gnus-article-edit-part (handles &optional current-id)
4991 "Edit an article in order to delete a mime part.
4992 This function is exclusively used by `gnus-mime-save-part-and-strip'
4993 and `gnus-mime-delete-part', and not provided at run-time normally."
4994 (gnus-article-edit-article
4995 `(lambda ()
4996 (buffer-disable-undo)
4997 (let ((mail-parse-charset (or gnus-article-charset
4998 ',gnus-newsgroup-charset))
4999 (mail-parse-ignored-charsets
5000 (or gnus-article-ignored-charsets
5001 ',gnus-newsgroup-ignored-charsets))
5002 (mbl mml-buffer-list))
5003 (setq mml-buffer-list nil)
5004 ;; A new text must be inserted before deleting existing ones
5005 ;; at the end so as not to move existing markers of which
5006 ;; the insertion type is t.
5007 (delete-region
5008 (point-min)
5009 (prog1
5010 (goto-char (point-max))
5011 (insert-buffer-substring gnus-original-article-buffer)))
5012 (mime-to-mml ',handles)
5013 (setq gnus-article-mime-handles nil)
5014 (let ((mbl1 mml-buffer-list))
5015 (setq mml-buffer-list mbl)
5016 (set (make-local-variable 'mml-buffer-list) mbl1))
5017 (gnus-make-local-hook 'kill-buffer-hook)
5018 (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t)))
5019 `(lambda (no-highlight)
5020 (let ((mail-parse-charset (or gnus-article-charset
5021 ',gnus-newsgroup-charset))
5022 (message-options message-options)
5023 (message-options-set-recipient)
5024 (mail-parse-ignored-charsets
5025 (or gnus-article-ignored-charsets
5026 ',gnus-newsgroup-ignored-charsets)))
5027 (mml-to-mime)
5028 (mml-destroy-buffers)
5029 (remove-hook 'kill-buffer-hook
5030 'mml-destroy-buffers t)
5031 (kill-local-variable 'mml-buffer-list))
5032 (gnus-summary-edit-article-done
5033 ,(or (mail-header-references gnus-current-headers) "")
5034 ,(gnus-group-read-only-p)
5035 ,gnus-summary-buffer no-highlight))
5036 t)
5037 ;; Force buttonizing this part.
5038 (let ((gnus-mime-buttonized-part-id current-id))
5039 (gnus-article-edit-done))
5040 (gnus-configure-windows 'article)
5041 (when (and current-id (integerp gnus-auto-select-part))
5042 (gnus-article-jump-to-part
5043 (min (max (+ current-id gnus-auto-select-part) 1)
5044 (with-current-buffer gnus-article-buffer
5045 (length gnus-article-mime-handle-alist)))))))
5047 (defun gnus-mime-replace-part (file)
5048 "Replace MIME part under point with an external body."
5049 ;; Useful if file has already been saved to disk
5050 (interactive
5051 (list
5052 (read-file-name "Replace MIME part with file: "
5053 (or mm-default-directory default-directory)
5054 nil nil)))
5055 (gnus-mime-save-part-and-strip file))
5057 (defun gnus-mime-save-part-and-strip (&optional file)
5058 "Save the MIME part under point then replace it with an external body.
5059 If FILE is given, use it for the external part."
5060 (interactive)
5061 (gnus-article-check-buffer)
5062 (when (gnus-group-read-only-p)
5063 (error "The current group does not support deleting of parts"))
5064 (when (mm-complicated-handles gnus-article-mime-handles)
5065 (error "\
5066 The current article has a complicated MIME structure, giving up..."))
5067 (let* ((data (get-text-property (point) 'gnus-data))
5068 (id (get-text-property (point) 'gnus-part))
5069 param
5070 (handles gnus-article-mime-handles))
5071 (unless file
5072 (setq file
5073 (and data (mm-save-part data "Delete MIME part and save to: "))))
5074 (when file
5075 (with-current-buffer (mm-handle-buffer data)
5076 (erase-buffer)
5077 (insert "Content-Type: " (mm-handle-media-type data))
5078 (mml-insert-parameter-string (cdr (mm-handle-type data))
5079 '(charset))
5080 ;; Add a filename for the sake of saving the part again.
5081 (mml-insert-parameter
5082 (mail-header-encode-parameter "name" (file-name-nondirectory file)))
5087 (setcdr data
5088 (cdr (mm-make-handle nil
5089 `("message/external-body"
5090 (access-type . "LOCAL-FILE")
5091 (name . ,file)))))
5092 ;; (set-buffer gnus-summary-buffer)
5093 (gnus-article-edit-part handles id))))
5095 ;; A function like `gnus-summary-save-parts' (`X m', `<MIME> <Extract all
5096 ;; parts...>') but with stripping would be nice.
5098 (defun gnus-mime-delete-part ()
5099 "Delete the MIME part under point.
5100 Replace it with some information about the removed part."
5101 (interactive)
5102 (gnus-article-check-buffer)
5103 (when (gnus-group-read-only-p)
5104 (error "The current group does not support deleting of parts"))
5105 (when (mm-complicated-handles gnus-article-mime-handles)
5106 (error "\
5107 The current article has a complicated MIME structure, giving up..."))
5108 (when (or gnus-expert-user
5109 (gnus-yes-or-no-p "\
5110 Deleting parts may malfunction or destroy the article; continue? "))
5111 (let* ((data (get-text-property (point) 'gnus-data))
5112 (id (get-text-property (point) 'gnus-part))
5113 (handles gnus-article-mime-handles)
5114 (description
5115 (let ((desc (mm-handle-description data)))
5116 (when desc
5117 (mail-decode-encoded-word-string desc))))
5118 (filename (or (mm-handle-filename data) "(none)"))
5119 (type (mm-handle-media-type data)))
5120 (unless data
5121 (error "No MIME part under point"))
5122 (with-current-buffer (mm-handle-buffer data)
5123 (let ((bsize (buffer-size)))
5124 (erase-buffer)
5125 (insert
5126 (concat
5133 bsize (if (= bsize 1)
5134 ""
5135 "s"))
5136 (when description
5139 (setcdr data
5140 (cdr (mm-make-handle
5141 nil `("text/plain" (charset . gnus-decoded)) nil nil
5142 (list "attachment")
5143 (format "Deleted attachment (%s bytes)" bsize))))))
5144 ;; (set-buffer gnus-summary-buffer)
5145 (gnus-article-edit-part handles id))))
5147 (defun gnus-mime-save-part ()
5148 "Save the MIME part under point."
5149 (interactive)
5150 (gnus-article-check-buffer)
5151 (let ((data (get-text-property (point) 'gnus-data)))
5152 (when data
5153 (mm-save-part data))))
5155 (defun gnus-mime-pipe-part (&optional cmd)
5156 "Pipe the MIME part under point to a process.
5157 Use CMD as the process."
5158 (interactive)
5159 (gnus-article-check-buffer)
5160 (let ((data (get-text-property (point) 'gnus-data)))
5161 (when data
5162 (mm-pipe-part data cmd))))
5164 (defun gnus-mime-view-part ()
5165 "Interactively choose a viewing method for the MIME part under point."
5166 (interactive)
5167 (gnus-article-check-buffer)
5168 (let ((data (get-text-property (point) 'gnus-data)))
5169 (when data
5170 (setq gnus-article-mime-handles
5171 (mm-merge-handles
5172 gnus-article-mime-handles (setq data (copy-sequence data))))
5173 (mm-interactively-view-part data))))
5175 (defun gnus-mime-view-part-as-type-internal ()
5176 (gnus-article-check-buffer)
5177 (let* ((handle (get-text-property (point) 'gnus-data))
5178 (name (or
5179 ;; Content-Type: foo/bar; name=...
5180 (mail-content-type-get (mm-handle-type handle) 'name)
5181 ;; Content-Disposition: attachment; filename=...
5182 (cdr (assq 'filename (cdr (mm-handle-disposition handle))))))
5183 (def-type (and name (mm-default-file-encoding name))))
5184 (or (and def-type (cons def-type 0))
5185 (and handle
5186 (equal (mm-handle-media-supertype handle) "text")
5187 '("text/plain" . 0))
5188 '("application/octet-stream" . 0))))
5190 (defun gnus-mime-view-part-as-type (&optional mime-type pred)
5191 "Choose a MIME media type, and view the part as such.
5192 If non-nil, PRED is a predicate to use during completion to limit the
5193 available media-types."
5194 (interactive)
5195 (unless mime-type
5196 (setq mime-type
5197 (let ((default (gnus-mime-view-part-as-type-internal)))
5198 (gnus-completing-read
5199 "View as MIME type"
5200 (if pred
5201 (gnus-remove-if-not pred (mailcap-mime-types))
5202 (mailcap-mime-types))
5203 nil nil nil
5204 (car default)))))
5205 (gnus-article-check-buffer)
5206 (let ((handle (get-text-property (point) 'gnus-data)))
5207 (when handle
5208 (when (equal (mm-handle-media-type handle) "message/external-body")
5209 (unless (mm-handle-cache handle)
5210 (mm-extern-cache-contents handle))
5211 (setq handle (mm-handle-cache handle)))
5212 (setq handle
5213 (mm-make-handle (mm-handle-buffer handle)
5214 (cons mime-type (cdr (mm-handle-type handle)))
5215 (mm-handle-encoding handle)
5216 (mm-handle-undisplayer handle)
5217 (mm-handle-disposition handle)
5218 (mm-handle-description handle)
5219 nil
5220 (mm-handle-id handle)))
5221 (setq gnus-article-mime-handles
5222 (mm-merge-handles gnus-article-mime-handles handle))
5223 (when (mm-handle-displayed-p handle)
5224 (mm-remove-part handle))
5225 (gnus-mm-display-part handle))))
5227 (defun gnus-mime-copy-part (&optional handle arg)
5228 "Put the MIME part under point into a new buffer.
5229 If `auto-compression-mode' is enabled, compressed files like .gz and .bz2
5230 are decompressed."
5231 (interactive (list nil current-prefix-arg))
5232 (gnus-article-check-buffer)
5233 (unless handle
5234 (setq handle (get-text-property (point) 'gnus-data)))
5235 (when handle
5236 (let ((filename (mm-handle-filename handle))
5237 contents dont-decode charset coding-system)
5238 (mm-with-unibyte-buffer
5239 (mm-insert-part handle)
5240 (setq contents (or (condition-case nil
5241 (mm-decompress-buffer filename nil 'sig)
5242 (error
5243 (setq dont-decode t)
5244 nil))
5245 (buffer-string))))
5246 (setq filename (cond (filename (file-name-nondirectory filename))
5247 (dont-decode "*raw data*")
5248 (t "*decoded*")))
5249 (cond
5250 (dont-decode)
5251 ((not arg)
5252 (unless (setq charset (mail-content-type-get
5253 (mm-handle-type handle) 'charset))
5254 (unless (setq coding-system (mm-with-unibyte-buffer
5255 (insert contents)
5256 (mm-find-buffer-file-coding-system)))
5257 (setq charset gnus-newsgroup-charset))))
5258 ((numberp arg)
5259 (setq charset (or (cdr (assq arg
5260 gnus-summary-show-article-charset-alist))
5261 (mm-read-coding-system "Charset: ")))))
5262 (switch-to-buffer (generate-new-buffer filename))
5263 (if (or coding-system
5264 (and charset
5265 (setq coding-system (mm-charset-to-coding-system
5266 charset nil t))
5267 (not (eq coding-system 'ascii))))
5268 (progn
5269 (mm-enable-multibyte)
5270 (insert (mm-decode-coding-string contents coding-system))
5271 (setq buffer-file-coding-system
5272 (if (boundp 'last-coding-system-used)
5273 (symbol-value 'last-coding-system-used)
5274 coding-system)))
5275 (mm-disable-multibyte)
5276 (insert contents)
5277 (setq buffer-file-coding-system mm-binary-coding-system))
5278 ;; We do it this way to make `normal-mode' set the appropriate mode.
5279 (unwind-protect
5280 (progn
5281 (setq buffer-file-name (expand-file-name filename))
5282 (normal-mode))
5283 (setq buffer-file-name nil))
5284 (goto-char (point-min)))))
5286 (defun gnus-mime-print-part (&optional handle filename)
5287 "Print the MIME part under point."
5288 (interactive (list nil (ps-print-preprint current-prefix-arg)))
5289 (gnus-article-check-buffer)
5290 (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
5291 (contents (and handle (mm-get-part handle)))
5292 (file (mm-make-temp-file (expand-file-name "mm." mm-tmp-directory)))
5293 (printer (mailcap-mime-info (mm-handle-media-type handle) "print")))
5294 (when contents
5295 (if printer
5296 (unwind-protect
5297 (progn
5298 (mm-save-part-to-file handle file)
5299 (call-process shell-file-name nil
5300 (generate-new-buffer " *mm*")
5301 nil
5302 shell-command-switch
5303 (mm-mailcap-command
5304 printer file (mm-handle-type handle))))
5305 (delete-file file))
5306 (with-temp-buffer
5307 (insert contents)
5308 (gnus-print-buffer))
5309 (ps-despool filename)))))
5311 (defun gnus-mime-inline-part (&optional handle arg)
5312 "Insert the MIME part under point into the current buffer.
5313 Compressed files like .gz and .bz2 are decompressed."
5314 (interactive (list nil current-prefix-arg))
5315 (gnus-article-check-buffer)
5316 (let* ((inhibit-read-only t)
5317 (b (point))
5318 (btn ;; position where the MIME button exists
5319 (if handle
5320 (if (eq handle (get-text-property b 'gnus-data))
5321 b
5322 (article-goto-body)
5323 (or (text-property-any (point) (point-max) 'gnus-data handle)
5324 (text-property-any (point-min) (point) 'gnus-data handle)))
5325 (setq handle (get-text-property b 'gnus-data))
5326 b))
5327 start contents charset coding-system)
5328 (when handle
5329 (when (= b (prog1
5330 btn
5331 (setq start (next-single-property-change btn 'gnus-data
5332 nil (point-max))
5333 btn (previous-single-property-change start
5334 'gnus-data))))
5335 (setq b btn))
5336 (if (and (not arg) (mm-handle-undisplayer handle))
5337 (mm-remove-part handle)
5338 (mm-with-unibyte-buffer
5339 (mm-insert-part handle)
5340 (setq contents
5341 (or (mm-decompress-buffer (mm-handle-filename handle) nil t)
5342 (buffer-string))))
5343 (cond
5344 ((not arg)
5345 (unless (setq charset (mail-content-type-get
5346 (mm-handle-type handle) 'charset))
5347 (unless (setq coding-system
5348 (mm-with-unibyte-buffer
5349 (insert contents)
5350 (mm-find-buffer-file-coding-system)))
5351 (setq charset gnus-newsgroup-charset))))
5352 ((numberp arg)
5353 (if (mm-handle-undisplayer handle)
5354 (mm-remove-part handle))
5355 (setq charset
5356 (or (cdr (assq arg
5357 gnus-summary-show-article-charset-alist))
5358 (mm-read-coding-system "Charset: "))))
5359 ((mm-handle-undisplayer handle)
5360 (mm-remove-part handle)))
5361 (goto-char start)
5362 (unless (bolp)
5363 ;; This is a header button.
5364 (forward-line 1))
5365 (mm-display-inline handle))
5366 ;; Toggle the button appearance between `[button]...' and `[button]'.
5367 (goto-char btn)
5368 (let ((displayed-p (mm-handle-displayed-p handle)))
5369 (gnus-insert-mime-button handle (get-text-property btn 'gnus-part)
5370 (list displayed-p))
5371 (if (featurep 'emacs)
5372 (delete-region
5373 (point)
5374 (next-single-property-change (point) 'gnus-data nil (point-max)))
5375 (let* ((end (next-single-property-change (point) 'gnus-data))
5376 (annots (annotations-at (or end (point-max)))))
5377 (delete-region (point)
5378 (if end
5379 (if annots (1+ end) end)
5380 (point-max)))
5381 (dolist (annot annots)
5382 (set-extent-endpoints annot (point) (point)))))
5383 (setq start (point))
5385 (progn
5386 (goto-char start)
5387 (unless (or displayed-p (eolp))
5388 ;; Add extra newline.
5389 (insert (propertize (buffer-substring (1- start) start)
5390 'gnus-undeletable t))))
5391 ;; We're in the article header.
5392 (delete-char -1)
5393 (dolist (ovl (gnus-overlays-in btn (point)))
5394 (gnus-overlay-put ovl 'gnus-button-attachment-extra t)
5395 (gnus-overlay-put ovl 'face nil))
5396 (save-restriction
5397 (message-narrow-to-field)
5398 (let ((gnus-treatment-function-alist
5399 '((gnus-treat-highlight-headers
5400 gnus-article-highlight-headers))))
5401 (gnus-treat-article 'head)))))
5402 (goto-char b))))
5404 (defun gnus-mime-set-charset-parameters (handle charset)
5405 "Set CHARSET to parameters in HANDLE.
5406 CHARSET may either be a string or a symbol."
5407 (unless (stringp charset)
5408 (setq charset (symbol-name charset)))
5409 (if (stringp (car handle))
5410 (dolist (h (cdr handle))
5411 (gnus-mime-set-charset-parameters h charset))
5412 (let* ((type (mm-handle-type (if (equal (mm-handle-media-type handle)
5413 "message/external-body")
5414 (progn
5415 (unless (mm-handle-cache handle)
5416 (mm-extern-cache-contents handle))
5417 (mm-handle-cache handle))
5418 handle)))
5419 (param (assq 'charset (cdr type))))
5420 (if param
5421 (setcdr param charset)
5422 (setcdr type (cons (cons 'charset charset) (cdr type)))))))
5424 (defun gnus-mime-view-part-as-charset (&optional handle arg)
5425 "Insert the MIME part under point into the current buffer using the
5426 specified charset."
5427 (interactive (list nil current-prefix-arg))
5428 (gnus-article-check-buffer)
5429 (let ((handle (or handle (get-text-property (point) 'gnus-data)))
5430 (fun (get-text-property (point) 'gnus-callback))
5431 (gnus-newsgroup-ignored-charsets 'gnus-all)
5432 charset form preferred parts)
5433 (when handle
5434 (when (prog1
5435 (and fun
5436 (setq charset
5437 (or (cdr (assq
5438 arg
5439 gnus-summary-show-article-charset-alist))
5440 (mm-read-coding-system "Charset: "))))
5441 (if (mm-handle-undisplayer handle)
5442 (mm-remove-part handle)))
5443 (gnus-mime-set-charset-parameters handle charset)
5444 (when (and (consp (setq form (cdr-safe fun)))
5445 (setq form (ignore-errors
5446 (assq 'gnus-mime-display-alternative form)))
5447 (setq preferred (caddr form))
5448 (progn
5449 (when (eq (car preferred) 'quote)
5450 (setq preferred (cadr preferred)))
5451 (not (equal preferred
5452 (get-text-property (point) 'gnus-data))))
5453 (setq parts (get-text-property (point) 'gnus-part))
5454 (setq parts (cdr (assq parts
5455 gnus-article-mime-handle-alist)))
5456 (equal (mm-handle-media-type parts) "multipart/alternative")
5457 (setq parts (reverse (cdr parts))))
5458 (setcar (cddr form)
5459 (list 'quote (or (cadr (member preferred parts))
5460 (car parts)))))
5461 (funcall fun handle)))))
5463 (defun gnus-mime-view-part-externally (&optional handle)
5464 "View the MIME part under point with an external viewer."
5465 (interactive)
5466 (gnus-article-check-buffer)
5467 (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
5468 (mm-user-display-methods nil)
5469 (mm-inlined-types nil)
5470 (mail-parse-charset gnus-newsgroup-charset)
5471 (mail-parse-ignored-charsets
5472 (with-current-buffer gnus-summary-buffer
5473 gnus-newsgroup-ignored-charsets))
5474 (type (mm-handle-media-type handle))
5475 (method (mailcap-mime-info type))
5476 (mm-enable-external t))
5477 (if (not (stringp method))
5478 (gnus-mime-view-part-as-type
5479 nil (lambda (type) (stringp (mailcap-mime-info type))))
5480 (when handle
5481 (mm-display-part handle nil t)))))
5483 (defun gnus-mime-view-part-internally (&optional handle)
5484 "View the MIME part under point with an internal viewer.
5485 If no internal viewer is available, use an external viewer."
5486 (interactive)
5487 (gnus-article-check-buffer)
5488 (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
5489 (mm-inlined-types '(".*"))
5490 (mm-inline-large-images t)
5491 (mail-parse-charset gnus-newsgroup-charset)
5492 (mail-parse-ignored-charsets
5493 (with-current-buffer gnus-summary-buffer
5494 gnus-newsgroup-ignored-charsets))
5495 (inhibit-read-only t))
5496 (if (not (mm-inlinable-p handle))
5497 (gnus-mime-view-part-as-type
5498 nil (lambda (type) (mm-inlinable-p handle type)))
5499 (when handle
5500 (gnus-bind-safe-url-regexp (mm-display-part handle))))))
5502 (defun gnus-mime-action-on-part (&optional action)
5503 "Do something with the MIME attachment at \(point\)."
5504 (interactive
5505 (list (gnus-completing-read "Action" (mapcar 'car gnus-mime-action-alist) t)))
5506 (gnus-article-check-buffer)
5507 (let ((action-pair (assoc action gnus-mime-action-alist)))
5508 (if action-pair
5509 (funcall (cdr action-pair)))))
5511 (defun gnus-article-part-wrapper (n function &optional no-handle interactive)
5512 "Call FUNCTION on MIME part N.
5513 Unless NO-HANDLE, call FUNCTION with N-th MIME handle as its only argument.
5514 If INTERACTIVE, call FUNCTION interactively."
5515 (let (window frame)
5516 ;; Check whether the article is displayed.
5517 (unless (and (gnus-buffer-live-p gnus-article-buffer)
5518 (setq window (get-buffer-window gnus-article-buffer t))
5519 (frame-visible-p (setq frame (window-frame window))))
5520 (error "No article is displayed"))
5521 (with-current-buffer gnus-article-buffer
5522 ;; Check whether the article displays the right contents.
5523 (unless (with-current-buffer gnus-summary-buffer
5524 (eq gnus-current-article (gnus-summary-article-number)))
5525 (error "You should select the right article first"))
5526 (if n
5527 (setq n (prefix-numeric-value n))
5528 (let ((pt (point)))
5529 (setq n (or (get-text-property pt 'gnus-part)
5530 (and (not (bobp))
5531 (get-text-property (1- pt) 'gnus-part))
5532 (get-text-property (prog2
5533 (forward-line 1)
5534 (point)
5535 (goto-char pt))
5536 'gnus-part)
5537 (get-text-property
5538 (or (and (setq pt (previous-single-property-change
5539 pt 'gnus-part))
5540 (1- pt))
5541 (next-single-property-change (point) 'gnus-part)
5542 (point))
5543 'gnus-part)
5544 1))))
5545 ;; Check whether the specified part exists.
5546 (when (> n (length gnus-article-mime-handle-alist))
5547 (error "No such part")))
5548 (unless
5549 (progn
5550 ;; To select the window is needed so that the cursor
5551 ;; might be visible on the MIME button.
5552 (select-window (prog1
5553 window
5554 (setq window (selected-window))
5555 ;; Article may be displayed in the other frame.
5556 (gnus-select-frame-set-input-focus
5557 (prog1
5558 frame
5559 (setq frame (selected-frame))))))
5560 (when (gnus-article-goto-part n)
5561 ;; We point the cursor and the arrow at the MIME button
5562 ;; when the `function' prompt the user for something.
5563 (unless (and (pos-visible-in-window-p)
5564 (> (count-lines (point) (window-end))
5565 (/ (1- (window-height)) 3)))
5566 (recenter (/ (1- (window-height)) 3)))
5567 (let ((cursor-in-non-selected-windows t)
5568 (overlay-arrow-string "=>")
5569 (overlay-arrow-position (point-marker)))
5570 (unwind-protect
5571 (cond
5572 ((and no-handle interactive)
5573 (call-interactively function))
5574 (no-handle
5575 (funcall function))
5576 (interactive
5577 (call-interactively
5578 function (get-text-property (point) 'gnus-data)))
5579 (t
5580 (funcall function
5581 (get-text-property (point) 'gnus-data))))
5582 (set-marker overlay-arrow-position nil)
5583 (unless gnus-auto-select-part
5584 (gnus-select-frame-set-input-focus frame)
5585 (select-window window))))
5586 t))
5587 (if gnus-inhibit-mime-unbuttonizing
5588 ;; This is the default though the program shouldn't reach here.
5589 (error "No such part")
5590 ;; The part which doesn't have the MIME button is selected.
5591 ;; So, we display all the buttons and redo it.
5592 (let ((gnus-inhibit-mime-unbuttonizing t))
5593 (gnus-summary-show-article)
5594 (gnus-article-part-wrapper n function no-handle))))))
5596 (defun gnus-article-pipe-part (n)
5597 "Pipe MIME part N, which is the numerical prefix."
5598 (interactive "P")
5599 (gnus-article-part-wrapper n 'mm-pipe-part))
5601 (defun gnus-article-save-part (n)
5602 "Save MIME part N, which is the numerical prefix."
5603 (interactive "P")
5604 (gnus-article-part-wrapper n 'mm-save-part))
5606 (defun gnus-article-interactively-view-part (n)
5607 "View MIME part N interactively, which is the numerical prefix."
5608 (interactive "P")
5609 (gnus-article-part-wrapper n 'mm-interactively-view-part))
5611 (defun gnus-article-copy-part (n)
5612 "Copy MIME part N, which is the numerical prefix."
5613 (interactive "P")
5614 (gnus-article-part-wrapper n 'gnus-mime-copy-part))
5616 (defun gnus-article-view-part-as-charset (n)
5617 "View MIME part N using a specified charset.
5618 N is the numerical prefix."
5619 (interactive "P")
5620 (gnus-article-part-wrapper n 'gnus-mime-view-part-as-charset))
5622 (defun gnus-article-view-part-externally (n)
5623 "View MIME part N externally, which is the numerical prefix."
5624 (interactive "P")
5625 (gnus-article-part-wrapper n 'gnus-mime-view-part-externally))
5627 (defun gnus-article-inline-part (n)
5628 "Inline MIME part N, which is the numerical prefix."
5629 (interactive "P")
5630 (gnus-article-part-wrapper n 'gnus-mime-inline-part))
5632 (defun gnus-article-save-part-and-strip (n)
5633 "Save MIME part N and replace it with an external body.
5634 N is the numerical prefix."
5635 (interactive "P")
5636 (gnus-article-part-wrapper n 'gnus-mime-save-part-and-strip t))
5638 (defun gnus-article-replace-part (n)
5639 "Replace MIME part N with an external body.
5640 N is the numerical prefix."
5641 (interactive "P")
5642 (gnus-article-part-wrapper n 'gnus-mime-replace-part t t))
5644 (defun gnus-article-delete-part (n)
5645 "Delete MIME part N and add some information about the removed part.
5646 N is the numerical prefix."
5647 (interactive "P")
5648 (gnus-article-part-wrapper n 'gnus-mime-delete-part t))
5650 (defun gnus-article-view-part-as-type (n)
5651 "Choose a MIME media type, and view part N as such.
5652 N is the numerical prefix."
5653 (interactive "P")
5654 (gnus-article-part-wrapper n 'gnus-mime-view-part-as-type t))
5656 (defun gnus-article-mime-match-handle-first (condition)
5657 (if condition
5658 (let (n)
5659 (dolist (ihandle gnus-article-mime-handle-alist)
5660 (if (and (cond
5661 ((functionp condition)
5662 (funcall condition (cdr ihandle)))
5663 ((eq condition 'undisplayed)
5664 (not (or (mm-handle-undisplayer (cdr ihandle))
5665 (equal (mm-handle-media-type (cdr ihandle))
5666 "multipart/alternative"))))
5667 ((eq condition 'undisplayed-alternative)
5668 (not (mm-handle-undisplayer (cdr ihandle))))
5669 (t t))
5670 (gnus-article-goto-part (car ihandle))
5671 (or (not n) (< (car ihandle) n)))
5672 (setq n (car ihandle))))
5673 (or n 1))
5674 1))
5676 (defun gnus-article-view-part (&optional n)
5677 "View MIME part N, which is the numerical prefix.
5678 If the part is already shown, hide the part. If N is nil, view
5679 all parts."
5680 (interactive "P")
5681 (with-current-buffer gnus-article-buffer
5682 (or (numberp n) (setq n (gnus-article-mime-match-handle-first
5683 gnus-article-mime-match-handle-function)))
5684 (when (> n (length gnus-article-mime-handle-alist))
5685 (error "No such part"))
5686 (let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
5687 (when (gnus-article-goto-part n)
5688 (if (equal (car handle) "multipart/alternative")
5689 (progn
5690 (beginning-of-line) ;; Make it toggle subparts
5691 (gnus-article-press-button))
5692 (when (eq (gnus-mm-display-part handle) 'internal)
5693 (gnus-set-window-start)))))))
5695 (defsubst gnus-article-mime-total-parts ()
5696 (if (bufferp (car gnus-article-mime-handles))
5697 1 ;; single part
5698 (1- (length gnus-article-mime-handles))))
5700 (defun gnus-mm-display-part (handle)
5701 "Display HANDLE and fix MIME button."
5702 (let ((id (get-text-property (point) 'gnus-part))
5703 (point (point))
5704 (inhibit-read-only t)
5705 (window (selected-window))
5706 (mail-parse-charset gnus-newsgroup-charset)
5707 (mail-parse-ignored-charsets
5708 (if (gnus-buffer-live-p gnus-summary-buffer)
5709 (with-current-buffer gnus-summary-buffer
5710 gnus-newsgroup-ignored-charsets)
5711 nil))
5712 start retval)
5713 (unwind-protect
5714 (progn
5715 (let ((win (gnus-get-buffer-window (current-buffer) t)))
5716 (when win
5717 (select-window win)
5718 (goto-char point)))
5719 (setq start (next-single-property-change point 'gnus-data
5720 nil (point-max))
5721 point (previous-single-property-change start 'gnus-data))
5722 (if (mm-handle-displayed-p handle)
5723 ;; This will remove the part.
5724 (setq retval (mm-display-part handle))
5725 (let ((part (or (and (mm-inlinable-p handle)
5726 (mm-inlined-p handle)
5727 t)
5728 (with-temp-buffer
5729 (gnus-bind-safe-url-regexp
5730 (setq retval (mm-display-part handle)))
5731 (unless (zerop (buffer-size))
5732 (buffer-string))))))
5733 (goto-char start)
5734 (unless (bolp)
5735 ;; This is a header button.
5736 (forward-line 1))
5737 (cond ((stringp part)
5738 (save-restriction
5739 (narrow-to-region (point)
5740 (progn
5741 (insert part)
5743 (point)))
5744 (gnus-treat-article nil id
5745 (gnus-article-mime-total-parts)
5746 (mm-handle-media-type handle))
5747 (mm-handle-set-undisplayer
5748 handle
5749 `(lambda ()
5750 (let ((inhibit-read-only t))
5751 (delete-region ,(copy-marker (point-min) t)
5752 ,(point-max-marker)))))))
5753 (part
5754 (mm-display-inline handle))))))
5755 (goto-char point)
5756 ;; Toggle the button appearance between `[button]...' and `[button]'.
5757 (let ((displayed-p (mm-handle-displayed-p handle)))
5758 (gnus-insert-mime-button handle id (list displayed-p))
5759 (if (featurep 'emacs)
5760 (delete-region
5761 (point)
5762 (next-single-property-change (point) 'gnus-data nil (point-max)))
5763 (let* ((end (next-single-property-change (point) 'gnus-data))
5764 (annots (annotations-at (or end (point-max)))))
5765 (delete-region (point)
5766 (if end
5767 (if annots (1+ end) end)
5768 (point-max)))
5769 (dolist (annot annots)
5770 (set-extent-endpoints annot (point) (point)))))
5771 (setq start (point))
5773 (progn
5774 (goto-char start)
5775 (unless (or displayed-p (eolp))
5776 ;; Add extra newline.
5777 (insert (propertize (buffer-substring (1- start) start)
5778 'gnus-undeletable t))))
5779 ;; We're in the article header.
5780 (delete-char -1)
5781 (dolist (ovl (gnus-overlays-in point (point)))
5782 (gnus-overlay-put ovl 'gnus-button-attachment-extra t)
5783 (gnus-overlay-put ovl 'face nil))
5784 (save-restriction
5785 (message-narrow-to-field)
5786 (let ((gnus-treatment-function-alist
5787 '((gnus-treat-highlight-headers
5788 gnus-article-highlight-headers))))
5789 (gnus-treat-article 'head)))))
5790 (goto-char point)
5791 (if (window-live-p window)
5792 (select-window window)))
5793 retval))
5795 (defun gnus-article-goto-part (n)
5796 "Go to MIME part N."
5797 (when gnus-break-pages
5798 (widen))
5799 (article-goto-body)
5800 (prog1
5801 (let ((start (or (text-property-any (point) (point-max) 'gnus-part n)
5802 ;; There may be header buttons.
5803 (text-property-any (point-min) (point) 'gnus-part n)))
5804 part handle end next handles)
5805 (when start
5806 (goto-char start)
5807 (if (setq handle (get-text-property start 'gnus-data))
5808 start
5809 ;; Go to the displayed subpart, assuming this is
5810 ;; multipart/alternative.
5811 (setq part start
5812 end (point-at-eol))
5813 (while (and (not handle)
5814 part
5815 (< part end)
5816 (setq next (text-property-not-all part end
5817 'gnus-data nil)))
5818 (setq part next
5819 handle (get-text-property part 'gnus-data))
5820 (push (cons handle part) handles)
5821 (unless (mm-handle-displayed-p handle)
5822 (setq handle nil
5823 part (text-property-any part end 'gnus-data nil))))
5824 (unless handle
5825 ;; No subpart is displayed, so we find preferred one.
5826 (setq part
5827 (cdr (assq (mm-preferred-alternative
5828 (nreverse (mapcar 'car handles)))
5829 handles))))
5830 (if part
5831 (goto-char (1+ part))
5832 start))))
5833 (when gnus-break-pages
5834 (gnus-narrow-to-page))))
5836 (defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed)
5837 (let ((gnus-tmp-name
5838 (or (mm-handle-filename handle)
5839 (mail-content-type-get (mm-handle-type handle) 'url)
5840 ""))
5841 (gnus-tmp-type (mm-handle-media-type handle))
5842 (gnus-tmp-description (or (mm-handle-description handle) ""))
5843 (gnus-tmp-dots
5844 (if (if displayed (car displayed)
5845 (mm-handle-displayed-p handle))
5846 "" "..."))
5847 (gnus-tmp-length (with-current-buffer (mm-handle-buffer handle)
5848 (buffer-size)))
5849 gnus-tmp-type-long b e)
5850 (when (string-match ".*/" gnus-tmp-name)
5851 (setq gnus-tmp-name (replace-match "" t t gnus-tmp-name)))
5852 (setq gnus-tmp-type-long (concat gnus-tmp-type
5853 (and (not (equal gnus-tmp-name ""))
5854 (concat "; " gnus-tmp-name))))
5855 (unless (equal gnus-tmp-description "")
5856 (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long)))
5857 (setq b (point))
5858 (gnus-eval-format
5859 gnus-mime-button-line-format gnus-mime-button-line-format-alist
5860 `(keymap ,gnus-mime-button-map
5861 gnus-callback gnus-mm-display-part
5862 gnus-part ,gnus-tmp-id
5863 article-type annotation
5864 gnus-data ,handle
5865 rear-nonsticky t))
5866 (setq e (if (bolp)
5867 ;; Exclude a newline.
5868 (1- (point))
5869 (point)))
5870 (when gnus-article-button-face
5871 (gnus-overlay-put (gnus-make-overlay b e nil t)
5872 'face gnus-article-button-face))
5873 (widget-convert-button
5874 'link b e
5875 :mime-handle handle
5876 :action 'gnus-widget-press-button
5877 :button-keymap gnus-mime-button-map
5878 :help-echo
5879 (lambda (widget)
5880 ;; Needed to properly clear the message due to a bug in
5881 ;; wid-edit (XEmacs only).
5882 (if (boundp 'help-echo-owns-message)
5883 (setq help-echo-owns-message t))
5884 (format
5885 "%S: %s the MIME part; %S: more options"
5886 (aref gnus-mouse-2 0)
5887 (if (mm-handle-displayed-p (widget-get widget :mime-handle))
5888 "hide" "show")
5889 (aref gnus-down-mouse-3 0))))))
5891 (defun gnus-widget-press-button (elems el)
5892 (goto-char (widget-get elems :from))
5893 (gnus-article-press-button))
5895 (defvar gnus-displaying-mime nil)
5897 (defun gnus-display-mime (&optional ihandles)
5898 "Display the MIME parts."
5899 (save-excursion
5900 (save-selected-window
5901 (let ((window (get-buffer-window gnus-article-buffer))
5902 (point (point)))
5903 (when window
5904 (select-window window)
5905 ;; We have to do this since selecting the window
5906 ;; may change the point. So we set the window point.
5907 (set-window-point window point)))
5908 (let ((handles ihandles)
5909 (inhibit-read-only t)
5910 handle)
5911 (cond (handles)
5912 ((setq handles (mm-dissect-buffer nil gnus-article-loose-mime))
5913 (when gnus-article-emulate-mime
5914 (mm-uu-dissect-text-parts handles)))
5915 (gnus-article-emulate-mime
5916 (setq handles (mm-uu-dissect))))
5917 (when (and (not ihandles)
5918 (not gnus-displaying-mime))
5919 ;; Top-level call; we clean up.
5920 (when gnus-article-mime-handles
5921 (mm-destroy-parts gnus-article-mime-handles)
5922 (setq gnus-article-mime-handle-alist nil));; A trick.
5923 (setq gnus-article-mime-handles handles)
5924 ;; We allow users to glean info from the handles.
5925 (when gnus-article-mime-part-function
5926 (gnus-mime-part-function handles)))
5927 (if (and handles
5928 (or (not (stringp (car handles)))
5929 (cdr handles)))
5930 (progn
5931 (when (and (not ihandles)
5932 (not gnus-displaying-mime))
5933 ;; Clean up for mime parts.
5934 (article-goto-body)
5935 (delete-region (point) (point-max)))
5936 (let ((gnus-displaying-mime t))
5937 (gnus-mime-display-part handles)))
5938 (save-restriction
5939 (article-goto-body)
5940 (narrow-to-region (point) (point-max))
5941 (gnus-treat-article nil 1 1 "text/plain")
5942 (widen)))
5943 (unless ihandles
5944 ;; Highlight the headers.
5945 (save-excursion
5946 (save-restriction
5947 (article-goto-body)
5948 (narrow-to-region (point-min) (point))
5949 (gnus-article-save-original-date
5950 (gnus-treat-article 'head)))))))
5951 ;; Cope with broken MIME messages.
5952 (goto-char (point-max))
5953 (unless (bolp)
5956 (defcustom gnus-mime-display-multipart-as-mixed nil
5959 If t, it overrides nil values of
5960 `gnus-mime-display-multipart-alternative-as-mixed' and
5961 `gnus-mime-display-multipart-related-as-mixed'."
5962 :group 'gnus-article-mime
5963 :type 'boolean)
5965 (defcustom gnus-mime-display-multipart-alternative-as-mixed nil
5967 :version "22.1"
5968 :group 'gnus-article-mime
5969 :type 'boolean)
5971 (defcustom gnus-mime-display-multipart-related-as-mixed nil
5975 `mm-discouraged-alternatives'\) images or other material inside a
5977 :version "22.1"
5978 :group 'gnus-article-mime
5979 :type 'boolean)
5981 (defcustom gnus-mime-display-attachment-buttons-in-header t
5982 "Add attachment buttons in the end of the header of an article.
5983 Since MIME attachments tend to be put at the end of an article, we may
5984 overlook them if there is a huge body. This option offers you a copy
5985 of all non-inlinable MIME parts as buttons shown in front of an article.
5986 If nil, don't show those extra buttons."
5987 :version "25.1"
5988 :group 'gnus-article-mime
5989 :type 'boolean)
5991 (defun gnus-mime-display-part (handle)
5992 (cond
5993 ;; Maybe a broken MIME message.
5994 ((null handle))
5995 ;; Single part.
5996 ((not (stringp (car handle)))
5997 (gnus-mime-display-single handle))
5998 ;; User-defined multipart
5999 ((cdr (assoc (car handle) gnus-mime-multipart-functions))
6000 (funcall (cdr (assoc (car handle) gnus-mime-multipart-functions))
6001 handle))
6002 ;; multipart/alternative
6003 ((and (equal (car handle) "multipart/alternative")
6004 (not (or gnus-mime-display-multipart-as-mixed
6005 gnus-mime-display-multipart-alternative-as-mixed)))
6006 (let ((id (1+ (length gnus-article-mime-handle-alist))))
6007 (push (cons id handle) gnus-article-mime-handle-alist)
6008 (gnus-mime-display-alternative (cdr handle) nil nil id)))
6009 ;; multipart/related
6010 ((and (equal (car handle) "multipart/related")
6011 (not (or gnus-mime-display-multipart-as-mixed
6012 gnus-mime-display-multipart-related-as-mixed)))
6013 (gnus-mime-display-part (cadr handle)))
6014 ((equal (car handle) "multipart/signed")
6015 (gnus-add-wash-type 'signed)
6016 (gnus-mime-display-security handle))
6017 ((equal (car handle) "multipart/encrypted")
6018 (gnus-add-wash-type 'encrypted)
6019 (gnus-mime-display-security handle))
6020 ;; Other multiparts are handled like multipart/mixed.
6021 (t
6022 (gnus-mime-display-mixed (cdr handle)))))
6024 (defun gnus-mime-part-function (handles)
6025 (if (stringp (car handles))
6026 (mapcar 'gnus-mime-part-function (cdr handles))
6027 (funcall gnus-article-mime-part-function handles)))
6029 (defun gnus-mime-display-mixed (handles)
6030 (mapcar 'gnus-mime-display-part handles))
6032 (defun gnus-mime-display-single (handle)
6033 (let ((type (mm-handle-media-type handle))
6034 (ignored gnus-ignored-mime-types)
6035 (not-attachment t)
6036 display text)
6037 (catch 'ignored
6038 (progn
6039 (while ignored
6040 (when (string-match (pop ignored) type)
6041 (throw 'ignored nil)))
6042 (if (and (not (and (if (gnus-buffer-live-p gnus-summary-buffer)
6043 (with-current-buffer gnus-summary-buffer
6044 gnus-inhibit-images)
6045 gnus-inhibit-images)
6047 (setq not-attachment
6048 (and (not (mm-inline-override-p handle))
6049 (or (not (mm-handle-disposition handle))
6050 (equal (car (mm-handle-disposition handle))
6051 "inline")
6052 (mm-attachment-override-p handle))))
6053 (mm-automatic-display-p handle)
6054 (or (and
6055 (mm-inlinable-p handle)
6056 (mm-inlined-p handle))
6057 (mm-automatic-external-display-p type)))
6058 (setq display t)
6059 (when (equal (mm-handle-media-supertype handle) "text")
6060 (setq text t)))
6061 (let ((id (car (rassq handle gnus-article-mime-handle-alist)))
6062 beg)
6063 (unless id
6064 (setq id (1+ (length gnus-article-mime-handle-alist)))
6065 (push (cons id handle) gnus-article-mime-handle-alist))
6066 (when (and display
6067 (equal (mm-handle-media-supertype handle) "message"))
6068 (insert-char
6070 (cond ((not (bolp)) 2)
6072 (t 1))))
6073 (when (or (not display)
6074 (not (gnus-unbuttonized-mime-type-p type))
6075 (eq id gnus-mime-buttonized-part-id))
6076 (gnus-insert-mime-button
6077 handle id (list (or display (and not-attachment text)))))
6078 (setq beg (point))
6079 (cond
6080 (display
6081 (let ((mail-parse-charset gnus-newsgroup-charset)
6082 (mail-parse-ignored-charsets
6083 (save-excursion (condition-case ()
6084 (set-buffer gnus-summary-buffer)
6085 (error))
6086 gnus-newsgroup-ignored-charsets)))
6087 (gnus-bind-safe-url-regexp (mm-display-part handle t))))
6088 ((and text not-attachment)
6089 (mm-display-inline handle)))
6090 (goto-char (point-max))
6092 (gnus-article-insert-newline)
6093 (if (prog1
6095 (forward-char 1))
6096 (gnus-article-insert-newline)
6097 (put-text-property (point) (point-max) 'gnus-undeletable t))
6098 (goto-char (point-max)))
6099 ;; Do highlighting.
6100 (save-excursion
6101 (save-restriction
6102 (narrow-to-region beg (point))
6103 (if (eq handle gnus-article-mime-handles)
6104 ;; The format=flowed case.
6105 (gnus-treat-article nil 1 1 (mm-handle-media-type handle))
6106 ;; Don't count signature parts that are never displayed.
6107 ;; The part number should be re-calculated supposing this
6108 ;; might be a message/rfc822 part.
6109 (let (handles)
6110 (dolist (part gnus-article-mime-handles)
6111 (unless (or (stringp part)
6112 (equal (car (mm-handle-type part))
6113 "application/pgp-signature"))
6114 (push part handles)))
6115 (gnus-treat-article
6116 nil (length (memq handle handles)) (length handles)
6117 (mm-handle-media-type handle)))))))))))
6119 (defun gnus-unbuttonized-mime-type-p (type)
6120 "Say whether TYPE is to be unbuttonized."
6121 (unless gnus-inhibit-mime-unbuttonizing
6122 (when (catch 'found
6123 (let ((types gnus-unbuttonized-mime-types))
6124 (while types
6125 (when (string-match (pop types) type)
6126 (throw 'found t)))))
6127 (not (catch 'found
6128 (let ((types gnus-buttonized-mime-types))
6129 (while types
6130 (when (string-match (pop types) type)
6131 (throw 'found t)))))))))
6133 (defun gnus-article-insert-newline ()
6134 "Insert a newline, but mark it as undeletable."
6135 (gnus-put-text-property
6138 (defun gnus-mime-display-alternative (handles &optional preferred ibegend id)
6139 (let* ((preferred (or preferred (mm-preferred-alternative handles)))
6140 (ihandles handles)
6141 (point (point))
6142 handle (inhibit-read-only t) from props begend not-pref)
6143 (save-window-excursion
6144 (save-restriction
6145 (when ibegend
6146 (narrow-to-region (car ibegend)
6147 (or (cdr ibegend)
6148 (progn
6149 (goto-char (car ibegend))
6150 (forward-line 2)
6151 (point))))
6152 (delete-region (point-min) (point-max))
6153 (mm-remove-parts handles))
6154 (setq begend (list (point-marker)))
6155 ;; Do the toggle.
6156 (unless (setq not-pref (cadr (member preferred ihandles)))
6157 (setq not-pref (car ihandles)))
6158 (when (or ibegend
6159 (not preferred)
6160 (not (gnus-unbuttonized-mime-type-p
6161 "multipart/alternative")))
6162 (gnus-add-text-properties
6163 (setq from (point))
6164 (progn
6165 (insert (format "%d. " id))
6166 (point))
6167 `(gnus-callback
6168 (lambda (handles)
6169 (unless ,(not ibegend)
6170 (setq gnus-article-mime-handle-alist
6171 ',gnus-article-mime-handle-alist))
6172 (gnus-mime-display-alternative
6173 ',ihandles ',not-pref ',begend ,id))
6174 keymap ,gnus-mime-button-map
6175 ,gnus-mouse-face-prop ,gnus-article-mouse-face
6176 face ,gnus-article-button-face
6177 gnus-part ,id
6178 article-type multipart
6179 rear-nonsticky t))
6180 (widget-convert-button 'link from (point)
6181 :action 'gnus-widget-press-button
6182 :button-keymap gnus-widget-button-keymap)
6183 ;; Do the handles
6184 (while (setq handle (pop handles))
6185 (gnus-add-text-properties
6186 (setq from (point))
6187 (progn
6188 (insert (format "(%c) %-18s"
6189 (if (equal handle preferred) ?* ? )
6190 (mm-handle-media-type handle)))
6191 (point))
6192 `(gnus-callback
6193 (lambda (handles)
6194 (unless ,(not ibegend)
6195 (setq gnus-article-mime-handle-alist
6196 ',gnus-article-mime-handle-alist))
6197 (gnus-mime-display-alternative
6198 ',ihandles ',handle ',begend ,id))
6199 keymap ,gnus-mime-button-map
6200 ,gnus-mouse-face-prop ,gnus-article-mouse-face
6201 face ,gnus-article-button-face
6202 gnus-part ,id
6203 gnus-data ,handle
6204 rear-nonsticky t))
6205 (widget-convert-button 'link from (point)
6206 :action 'gnus-widget-press-button
6207 :button-keymap gnus-widget-button-keymap)
6208 (insert " "))
6210 (when preferred
6211 (if (stringp (car preferred))
6212 (gnus-display-mime preferred)
6213 (let ((mail-parse-charset gnus-newsgroup-charset)
6214 (mail-parse-ignored-charsets
6215 (with-current-buffer gnus-summary-buffer
6216 gnus-newsgroup-ignored-charsets)))
6217 (gnus-bind-safe-url-regexp (mm-display-part preferred))
6218 ;; Do highlighting.
6219 (save-excursion
6220 (save-restriction
6221 (narrow-to-region (car begend) (point-max))
6222 (gnus-treat-article
6223 nil (length gnus-article-mime-handle-alist)
6224 (gnus-article-mime-total-parts)
6225 (mm-handle-media-type preferred))))))
6226 (goto-char (point-max))
6227 (setcdr begend (point-marker)))))
6228 (when ibegend
6229 (goto-char point)))
6230 ;; Redraw attachment buttons in the header.
6231 (when gnus-mime-display-attachment-buttons-in-header
6232 (gnus-mime-buttonize-attachments-in-header)))
6234 (defconst gnus-article-wash-status-strings
6235 (let ((alist '((cite "c" "Possible hidden citation text"
6236 " " "All citation text visible")
6237 (headers "h" "Hidden headers"
6238 " " "All headers visible.")
6239 (pgp "p" "Encrypted or signed message status hidden"
6240 " " "No hidden encryption nor digital signature status")
6241 (signature "s" "Signature has been hidden"
6242 " " "Signature is visible")
6243 (overstrike "o" "Overstrike (^H) characters applied"
6244 " " "No overstrike characters applied")
6245 (emphasis "e" "/*_Emphasis_*/ characters applied"
6246 " " "No /*_emphasis_*/ characters applied")))
6247 result)
6248 (dolist (entry alist result)
6249 (let ((key (nth 0 entry))
6250 (on (copy-sequence (nth 1 entry)))
6251 (on-help (nth 2 entry))
6252 (off (copy-sequence (nth 3 entry)))
6253 (off-help (nth 4 entry)))
6254 (put-text-property 0 1 'help-echo on-help on)
6255 (put-text-property 0 1 'help-echo off-help off)
6256 (push (list key on off) result))))
6257 "Alist of strings describing wash status in the mode line.
6258 Each entry has the form (KEY ON OF), where the KEY is a symbol
6259 representing the particular washing function, ON is the string to use
6260 in the article mode line when the washing function is active, and OFF
6261 is the string to use when it is inactive.")
6263 (defun gnus-article-wash-status-entry (key value)
6264 (let ((entry (assoc key gnus-article-wash-status-strings)))
6265 (if value (nth 1 entry) (nth 2 entry))))
6267 (defun gnus-article-wash-status ()
6268 "Return a string which display status of article washing."
6269 (with-current-buffer gnus-article-buffer
6270 (let ((cite (memq 'cite gnus-article-wash-types))
6271 (headers (memq 'headers gnus-article-wash-types))
6272 (boring (memq 'boring-headers gnus-article-wash-types))
6273 (pgp (memq 'pgp gnus-article-wash-types))
6274 (pem (memq 'pem gnus-article-wash-types))
6275 (signed (memq 'signed gnus-article-wash-types))
6276 (encrypted (memq 'encrypted gnus-article-wash-types))
6277 (signature (memq 'signature gnus-article-wash-types))
6278 (overstrike (memq 'overstrike gnus-article-wash-types))
6279 (emphasis (memq 'emphasis gnus-article-wash-types)))
6280 (concat
6281 (gnus-article-wash-status-entry 'cite cite)
6282 (gnus-article-wash-status-entry 'headers (or headers boring))
6283 (gnus-article-wash-status-entry 'pgp (or pgp pem signed encrypted))
6284 (gnus-article-wash-status-entry 'signature signature)
6285 (gnus-article-wash-status-entry 'overstrike overstrike)
6286 (gnus-article-wash-status-entry 'emphasis emphasis)))))
6288 (defun gnus-add-wash-type (type)
6289 "Add a washing of TYPE to the current status."
6290 (add-to-list 'gnus-article-wash-types type))
6292 (defun gnus-delete-wash-type (type)
6293 "Add a washing of TYPE to the current status."
6294 (setq gnus-article-wash-types (delq type gnus-article-wash-types)))
6296 (defun gnus-add-image (category image)
6297 "Add IMAGE of CATEGORY to the list of displayed images."
6298 (let ((entry (assq category gnus-article-image-alist)))
6299 (unless entry
6300 (setq entry (list category))
6301 (push entry gnus-article-image-alist))
6302 (nconc entry (list image))))
6304 (defun gnus-delete-images (category)
6305 "Delete all images in CATEGORY."
6306 (let ((entry (assq category gnus-article-image-alist)))
6307 (dolist (image (cdr entry))
6308 (gnus-remove-image image category))
6309 (setq gnus-article-image-alist (delq entry gnus-article-image-alist))
6310 (gnus-delete-wash-type category)))
6312 (defalias 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers)
6314 (defun gnus-article-maybe-hide-headers ()
6315 "Hide unwanted headers if `gnus-have-all-headers' is nil.
6316 Provided for backwards compatibility."
6317 (when (and (or (not (gnus-buffer-live-p gnus-summary-buffer))
6318 (not (with-current-buffer gnus-summary-buffer
6319 gnus-have-all-headers)))
6320 (not gnus-inhibit-hiding))
6321 (gnus-article-hide-headers)))
6323 (declare-function shr-put-image "shr" (data alt &optional flags))
6325 (defun gnus-shr-put-image (data alt &optional flags)
6326 "Put image DATA with a string ALT. Enable image to be deleted."
6327 (let ((image (if flags
6328 (shr-put-image data (propertize (or alt "*")
6329 'gnus-image-category 'shr)
6330 flags)
6331 ;; Old `shr-put-image' doesn't take the optional `flags'
6332 ;; argument.
6333 (shr-put-image data (propertize (or alt "*")
6334 'gnus-image-category 'shr)))))
6335 (when image
6336 (gnus-add-image 'shr image))))
6338 (defun gnus-article-mime-handles (&optional alist id all)
6339 (if alist
6340 (let ((i 1) newid flat)
6341 (dolist (handle alist flat)
6342 (setq newid (append id (list i))
6343 i (1+ i))
6344 (if (stringp (car handle))
6345 (setq flat (nconc flat (gnus-article-mime-handles
6346 (cdr handle) newid all)))
6347 (delq (rassq handle all) all)
6348 (setq flat (nconc flat (list (cons newid handle)))))))
6349 (let ((flat (list nil)))
6350 ;; Assume that elements of `gnus-article-mime-handle-alist'
6351 ;; are in the decreasing order, but unnumbered subsidiaries
6352 ;; in each element are in the increasing order.
6353 (dolist (handle (reverse gnus-article-mime-handle-alist))
6354 (if (stringp (cadr handle))
6355 (setq flat (nconc flat (gnus-article-mime-handles
6356 (cddr handle) (list (car handle)) flat)))
6357 (delq (rassq (cdr handle) flat) flat)
6358 (setq flat (nconc flat (list (cons (list (car handle))
6359 (cdr handle)))))))
6360 (setq flat (cdr flat))
6361 (mapc (lambda (handle)
6362 (if (cdar handle)
6363 ;; This is a hidden (i.e. unnumbered) handle.
6364 (progn
6365 (setcar handle
6366 (1+ (caar gnus-article-mime-handle-alist)))
6367 (push handle gnus-article-mime-handle-alist))
6368 (setcar handle (caar handle))))
6369 flat)
6370 flat)))
6372 (defun gnus-mime-buttonize-attachments-in-header (&optional interactive)
6373 "Show attachments as buttons in the end of the header of an article.
6374 This function toggles the display when called interactively. Note that
6375 buttons to be added to the header are only the ones that aren't inlined
6376 in the body. Use `gnus-header-face-alist' to highlight buttons."
6377 (interactive (list t))
6378 (gnus-with-article-buffer
6379 (let ((case-fold-search t) buttons handle type st)
6380 (save-excursion
6381 (save-restriction
6382 (widen)
6383 (article-narrow-to-head)
6384 ;; Header buttons exist?
6385 (while (and (not buttons)
6387 (when (get-char-property (match-end 0)
6388 'gnus-button-attachment-extra)
6389 (setq buttons (match-beginning 0))))
6390 (widen)
6391 (when buttons
6392 ;; Delete header buttons.
6393 (delete-region buttons (if (re-search-forward "^[^ ]" nil t)
6394 (match-beginning 0)
6395 (point-max))))
6396 (unless (and interactive buttons)
6397 ;; Find buttons.
6398 (setq buttons nil)
6399 (dolist (button (gnus-article-mime-handles))
6400 (setq handle (cdr button)
6401 type (mm-handle-media-type handle))
6402 (when (or (and (if (gnus-buffer-live-p gnus-summary-buffer)
6403 (with-current-buffer gnus-summary-buffer
6404 gnus-inhibit-images)
6405 gnus-inhibit-images)
6407 (mm-inline-override-p handle)
6408 (and (mm-handle-disposition handle)
6409 (not (equal (car (mm-handle-disposition handle))
6410 "inline"))
6411 (not (mm-attachment-override-p handle)))
6412 (not (mm-automatic-display-p handle))
6413 (not (or (and (mm-inlinable-p handle)
6414 (mm-inlined-p handle))
6415 (mm-automatic-external-display-p type))))
6416 (push button buttons)))
6417 (when buttons
6418 ;; Add header buttons.
6419 (article-goto-body)
6420 (forward-line -1)
6421 (narrow-to-region (point) (point))
6422 (insert "Attachment" (if (cdr buttons) "s" "") ":")
6423 (dolist (button (nreverse buttons))
6424 (setq st (point))
6425 (insert " ")
6426 (mm-handle-set-undisplayer
6427 (setq handle (copy-sequence (cdr button))) nil)
6428 (gnus-insert-mime-button handle (car button))
6430 (delete-region (point) (point-max))
6431 (when (> (current-column) (window-width))
6432 (goto-char st)
6434 (end-of-line)))
6436 (dolist (ovl (gnus-overlays-in (point-min) (point)))
6437 (gnus-overlay-put ovl 'gnus-button-attachment-extra t)
6438 (gnus-overlay-put ovl 'face nil))
6439 (let ((gnus-treatment-function-alist
6440 '((gnus-treat-highlight-headers
6441 gnus-article-highlight-headers))))
6442 (gnus-treat-article 'head)))))))))
6444 ;;; Article savers.
6446 (defun gnus-output-to-file (file-name)
6447 "Append the current article to a file named FILE-NAME.
6448 If `gnus-article-save-coding-system' is non-nil, it is used to encode
6449 text and used as the value of the coding cookie which is added to the
6450 top of a file. Otherwise, this function saves a raw article without
6451 the coding cookie."
6452 (let* ((artbuf (current-buffer))
6453 (file-name-coding-system nnmail-pathname-coding-system)
6454 (coding gnus-article-save-coding-system)
6455 (coding-system-for-read (if coding
6456 nil ;; Rely on the coding cookie.
6457 mm-text-coding-system))
6458 (coding-system-for-write (or coding
6459 mm-text-coding-system-for-write
6460 mm-text-coding-system))
6461 (exists (file-exists-p file-name)))
6462 (with-temp-buffer
6463 (when exists
6464 (insert-file-contents file-name)
6465 (goto-char (point-min))
6466 ;; Remove the existing coding cookie.
6468 (delete-region (match-beginning 0) (match-end 0))))
6469 (goto-char (point-max))
6470 (insert-buffer-substring artbuf)
6471 ;; Append newline at end of the buffer as separator, and then
6472 ;; save it to file.
6473 (goto-char (point-max))
6475 (when coding
6476 ;; If the coding system is not suitable to encode the text,
6477 ;; ask a user for a proper one.
6478 (when (fboundp 'select-safe-coding-system)
6479 (setq coding (coding-system-base
6480 (save-window-excursion
6481 (select-safe-coding-system (point-min) (point-max)
6482 coding))))
6483 (setq coding-system-for-write
6484 (or (cdr (assq coding '((mule-utf-8 . utf-8))))
6485 coding)))
6486 (goto-char (point-min))
6487 ;; Add the coding cookie.
6489 coding-system-for-write)))
6490 (if exists
6491 (progn
6492 (write-region (point-min) (point-max) file-name nil 'no-message)
6493 (message "Appended to %s" file-name))
6494 (write-region (point-min) (point-max) file-name))))
6495 t)
6497 (defun gnus-narrow-to-page (&optional arg)
6498 "Narrow the article buffer to a page.
6499 If given a numerical ARG, move forward ARG pages."
6500 (interactive "P")
6501 (setq arg (if arg (prefix-numeric-value arg) 0))
6502 (with-current-buffer gnus-article-buffer
6503 (widen)
6504 ;; Remove any old next/prev buttons.
6505 (when (gnus-visual-p 'page-marker)
6506 (let ((inhibit-read-only t))
6507 (gnus-remove-text-with-property 'gnus-prev)
6508 (gnus-remove-text-with-property 'gnus-next)))
6509 (let (st nd pt)
6510 (when (save-excursion
6511 (cond ((< arg 0)
6512 (if (re-search-backward page-delimiter nil 'move (abs arg))
6513 (prog1
6514 (setq nd (match-beginning 0)
6515 pt nd)
6516 (when (re-search-backward page-delimiter nil t)
6517 (setq st (match-end 0))))
6518 (when (re-search-forward page-delimiter nil t)
6519 (setq nd (match-beginning 0)
6520 pt (point-min)))))
6521 ((> arg 0)
6522 (if (re-search-forward page-delimiter nil 'move arg)
6523 (prog1
6524 (setq st (match-end 0)
6525 pt st)
6526 (when (re-search-forward page-delimiter nil t)
6527 (setq nd (match-beginning 0))))
6528 (when (re-search-backward page-delimiter nil t)
6529 (setq st (match-end 0)
6530 pt (point-max)))))
6531 (t
6532 (when (re-search-backward page-delimiter nil t)
6533 (goto-char (setq st (match-end 0))))
6534 (when (re-search-forward page-delimiter nil t)
6535 (setq nd (match-beginning 0)))
6536 (or st nd))))
6537 (setq gnus-page-broken t)
6538 (when pt (goto-char pt))
6539 (narrow-to-region (or st (point-min)) (or nd (point-max)))
6540 (when (gnus-visual-p 'page-marker)
6541 (save-excursion
6542 (when nd
6543 (goto-char nd)
6544 (gnus-insert-next-page-button))
6545 (when st
6546 (goto-char st)
6547 (gnus-insert-prev-page-button))))))))
6549 ;; Article mode commands
6551 (defun gnus-article-goto-next-page ()
6552 "Show the next page of the article."
6553 (interactive)
6554 (when (gnus-article-next-page)
6555 (goto-char (point-min))
6556 (gnus-article-read-summary-keys nil (gnus-character-to-event ?n))))
6559 (defun gnus-article-goto-prev-page ()
6560 "Show the previous page of the article."
6561 (interactive)
6562 (if (save-restriction (widen) (bobp)) ;; Real beginning-of-buffer?
6563 (gnus-article-read-summary-keys nil (gnus-character-to-event ?p))
6564 (gnus-article-prev-page nil)))
6566 ;; This is cleaner but currently breaks `gnus-pick-mode':
6567 ;;
6568 ;; (defun gnus-article-goto-next-page ()
6569 ;; "Show the next page of the article."
6570 ;; (interactive)
6571 ;; (gnus-eval-in-buffer-window gnus-summary-buffer
6572 ;; (gnus-summary-next-page)))
6573 ;;
6574 ;; (defun gnus-article-goto-prev-page ()
6575 ;; "Show the next page of the article."
6576 ;; (interactive)
6577 ;; (gnus-eval-in-buffer-window gnus-summary-buffer
6578 ;; (gnus-summary-prev-page)))
6580 (defun gnus-article-next-page (&optional lines)
6581 "Show the next page of the current article.
6582 If end of article, return non-nil. Otherwise return nil.
6583 Argument LINES specifies lines to be scrolled up."
6584 (interactive "p")
6585 (move-to-window-line (if (featurep 'xemacs) -1 (- -1 scroll-margin)))
6586 (if (and (not (and gnus-article-over-scroll
6587 (> (count-lines (window-start) (point-max))
6588 (if (featurep 'xemacs)
6589 (or lines (1- (window-height)))
6590 (+ (or lines (1- (window-height))) scroll-margin)))))
6591 (save-excursion
6592 (end-of-line)
6593 (and (pos-visible-in-window-p) ;Not continuation line.
6594 (>= (point) (point-max)))))
6595 ;; Nothing in this page.
6596 (if (or (not gnus-page-broken)
6597 (save-excursion
6598 (save-restriction
6599 (widen)
6600 (forward-line)
6601 (eobp)))) ;Real end-of-buffer?
6602 (progn
6603 (when gnus-article-over-scroll
6604 (gnus-article-next-page-1 lines))
6605 t) ;Nothing more.
6606 (gnus-narrow-to-page 1) ;Go to next page.
6607 nil)
6608 ;; More in this page.
6609 (gnus-article-next-page-1 lines)
6610 nil))
6612 (defun gnus-article-beginning-of-window ()
6613 "Move point to the beginning of the window.
6614 In Emacs, the point is placed at the line number which `scroll-margin'
6615 specifies."
6616 (if (featurep 'xemacs)
6617 (move-to-window-line 0)
6618 ;; There is an obscure bug in Emacs that makes it impossible to
6619 ;; scroll past big pictures in the article buffer. Try to fix
6620 ;; this by adding a sanity check by counting the lines visible.
6621 (when (> (count-lines (window-start) (window-end)) 30)
6622 (move-to-window-line
6623 (min (max 0 scroll-margin)
6624 (max 1 (- (window-height)
6625 (if mode-line-format 1 0)
6626 (if header-line-format 1 0)
6627 2)))))))
6629 (defun gnus-article-next-page-1 (lines)
6630 (condition-case ()
6631 (let ((scroll-in-place nil)
6632 (auto-window-vscroll nil))
6633 (scroll-up lines))
6634 (end-of-buffer
6635 ;; Long lines may cause an end-of-buffer error.
6636 (goto-char (point-max))))
6637 (gnus-article-beginning-of-window))
6639 (defun gnus-article-prev-page (&optional lines)
6640 "Show previous page of current article.
6641 Argument LINES specifies lines to be scrolled down."
6642 (interactive "p")
6643 (move-to-window-line 0)
6644 (if (and gnus-page-broken
6645 (bobp)
6646 (not (save-restriction (widen) (bobp)))) ;Real beginning-of-buffer?
6647 (progn
6648 (gnus-narrow-to-page -1) ;Go to previous page.
6649 (goto-char (point-max))
6650 (recenter (if gnus-article-over-scroll
6651 (if lines
6652 (max (if (featurep 'xemacs)
6653 lines
6654 (+ lines scroll-margin))
6655 3)
6656 (- (window-height) 2))
6657 -1)))
6658 (prog1
6659 (condition-case ()
6660 (let ((scroll-in-place nil))
6661 (scroll-down lines))
6662 (beginning-of-buffer
6663 (goto-char (point-min))))
6664 (gnus-article-beginning-of-window))))
6666 (defun gnus-article-only-boring-p ()
6667 "Decide whether there is only boring text remaining in the article.
6669 not have a face in `gnus-article-boring-faces'."
6670 (when (and gnus-article-skip-boring
6671 (boundp 'gnus-article-boring-faces)
6672 (symbol-value 'gnus-article-boring-faces))
6673 (save-excursion
6674 (let ((inhibit-point-motion-hooks t))
6675 (catch 'only-boring
6677 (forward-char -1)
6678 (when (not (gnus-intersection
6679 (gnus-faces-at (point))
6680 (symbol-value 'gnus-article-boring-faces)))
6681 (throw 'only-boring nil)))
6682 (throw 'only-boring t))))))
6684 (defun gnus-article-refer-article ()
6685 "Read article specified by message-id around point."
6686 (interactive)
6687 (save-excursion
6691 (let ((msg-id (concat "<" (match-string 0) ">")))
6692 (set-buffer gnus-summary-buffer)
6693 (gnus-summary-refer-article msg-id))
6694 (error "No references around point"))))
6696 (defun gnus-article-show-summary ()
6697 "Reconfigure windows to show summary buffer."
6698 (interactive)
6699 (if (not (gnus-buffer-live-p gnus-summary-buffer))
6700 (error "There is no summary buffer for this article buffer")
6701 (gnus-article-set-globals)
6702 (gnus-configure-windows 'article)
6703 (gnus-summary-goto-subject gnus-current-article)
6704 (gnus-summary-position-point)))
6706 (defun gnus-article-describe-briefly ()
6707 "Describe article mode commands briefly."
6708 (interactive)
6709 (gnus-message 6 "%s" (substitute-command-keys "\\<gnus-article-mode-map>\\[gnus-article-goto-next-page]:Next page \\[gnus-article-goto-prev-page]:Prev page \\[gnus-article-show-summary]:Show summary \\[gnus-info-find-node]:Run Info \\[gnus-article-describe-briefly]:This help")))
6711 (defun gnus-article-check-buffer ()
6712 "Beep if not in an article buffer."
6713 (unless (derived-mode-p 'gnus-article-mode)
6714 (error "Command invoked outside of a Gnus article buffer")))
6716 (defun gnus-article-read-summary-keys (&optional arg key not-restore-window)
6717 "Read a summary buffer key sequence and execute it from the article buffer."
6718 (interactive "P")
6719 (gnus-article-check-buffer)
6720 (let ((nosaves
6721 '("q" "Q" "c" "r" "\C-c\C-f" "m" "a" "f"
6722 "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"
6723 "=" "^" "\M-^" "|"))
6724 (nosave-but-article
6726 "An" "Ap" [?A (meta return)] [?A delete]))
6727 (nosave-in-article
6728 '("AS" "\C-d"))
6729 (up-to-top
6730 '("n" "Gn" "p" "Gp"))
6731 keys new-sum-point)
6732 (with-current-buffer gnus-article-current-summary
6733 (let (gnus-pick-mode)
6734 (setq unread-command-events (nconc unread-command-events
6735 (list (or key last-command-event)))
6736 keys (if (featurep 'xemacs)
6737 (events-to-keys (read-key-sequence nil t))
6738 (read-key-sequence nil t)))))
6740 (message "")
6742 (cond
6743 ((eq (aref keys (1- (length keys))) ?\C-h)
6744 (gnus-article-describe-bindings (substring keys 0 -1)))
6745 ((or (member keys nosaves)
6746 (member keys nosave-but-article)
6747 (member keys nosave-in-article))
6748 (let (func)
6749 (save-window-excursion
6750 (pop-to-buffer gnus-article-current-summary)
6751 ;; We disable the pick minor mode commands.
6752 (let (gnus-pick-mode)
6753 (setq func (key-binding keys t))))
6754 (if (or (not func)
6755 (numberp func))
6756 (ding)
6757 (unless (member keys nosave-in-article)
6758 (set-buffer gnus-article-current-summary))
6759 (when (and (symbolp func)
6760 (get func 'disabled))
6761 (error "Function %s disabled" func))
6762 (call-interactively func)
6763 (setq new-sum-point (point)))
6764 (when (member keys nosave-but-article)
6765 (pop-to-buffer gnus-article-buffer))))
6766 (t
6767 ;; These commands should restore window configuration.
6768 (let ((obuf (current-buffer))
6769 (owin (current-window-configuration))
6770 win func in-buffer selected new-sum-start new-sum-hscroll err)
6771 (cond (not-restore-window
6772 (pop-to-buffer gnus-article-current-summary)
6773 (setq win (selected-window)))
6774 ((setq win (get-buffer-window gnus-article-current-summary))
6775 (select-window win))
6776 (t
6777 (let ((summary-buffer gnus-article-current-summary))
6778 (gnus-configure-windows 'article)
6779 (unless (setq win (get-buffer-window summary-buffer 'visible))
6780 (let ((gnus-buffer-configuration
6781 '((article ((vertical 1.0
6782 (summary 0.25 point)
6783 (article 1.0)))))))
6784 (gnus-configure-windows 'article))
6785 (setq win (get-buffer-window summary-buffer 'visible)))
6786 (gnus-select-frame-set-input-focus (window-frame win))
6787 (select-window win))))
6788 (setq in-buffer (current-buffer))
6789 ;; We disable the pick minor mode commands.
6790 (setq func (let (gnus-pick-mode)
6791 (key-binding keys t)))
6792 (when (get func 'disabled)
6793 (error "Function %s disabled" func))
6794 (if (and func
6795 (functionp func)
6796 (condition-case code
6797 (progn
6798 (call-interactively func)
6799 t)
6800 (error
6801 (setq err code)
6802 nil)))
6803 (progn
6804 (when (eq win (selected-window))
6805 (setq new-sum-point (point)
6806 new-sum-start (window-start win)
6807 new-sum-hscroll (window-hscroll win)))
6808 (when (or (eq in-buffer (current-buffer))
6809 (when (eq obuf (current-buffer))
6810 (set-buffer in-buffer)
6811 t))
6812 (setq selected (ignore-errors (gnus-summary-select-article)))
6813 (set-buffer obuf)
6814 (unless not-restore-window
6815 (set-window-configuration owin))
6816 (when (and (eq selected 'old)
6817 new-sum-point)
6818 (set-window-start (get-buffer-window (current-buffer))
6819 1)
6820 (set-window-point (get-buffer-window (current-buffer))
6821 (if (article-goto-body)
6822 (1- (point))
6823 (point))))
6824 (when (and (not not-restore-window)
6825 new-sum-point
6826 (window-live-p win)
6827 (with-current-buffer (window-buffer win)
6828 (derived-mode-p 'gnus-summary-mode)))
6829 (set-window-point win new-sum-point)
6830 (set-window-start win new-sum-start)
6831 (set-window-hscroll win new-sum-hscroll))))
6832 (set-window-configuration owin)
6833 (if err
6834 (signal (car err) (cdr err))
6835 (ding))))))))
6837 (defun gnus-article-read-summary-send-keys ()
6838 (interactive)
6839 (let ((unread-command-events (list (gnus-character-to-event ?S))))
6840 (gnus-article-read-summary-keys)))
6842 (defun gnus-article-describe-key (key)
6843 "Display documentation of the function invoked by KEY.
6844 KEY is a string or a vector."
6845 (interactive (list (let ((cursor-in-echo-area t)) ;; better for XEmacs.
6846 (read-key-sequence "Describe key: "))))
6847 (gnus-article-check-buffer)
6848 (if (memq (key-binding key t) '(gnus-article-read-summary-keys
6849 gnus-article-read-summary-send-keys))
6850 (with-current-buffer gnus-article-current-summary
6851 (setq unread-command-events
6852 (if (featurep 'xemacs)
6853 (append key nil)
6854 (mapcar (lambda (x) (if (and (integerp x) (>= x 128))
6855 (list 'meta (- x 128))
6856 x))
6857 key)))
6858 (let ((cursor-in-echo-area t)
6859 gnus-pick-mode)
6860 (describe-key (read-key-sequence nil t))))
6861 (describe-key key)))
6863 (defun gnus-article-describe-key-briefly (key &optional insert)
6864 "Display documentation of the function invoked by KEY.
6865 KEY is a string or a vector."
6866 (interactive (list (let ((cursor-in-echo-area t)) ;; better for XEmacs.
6867 (read-key-sequence "Describe key: "))
6868 current-prefix-arg))
6869 (gnus-article-check-buffer)
6870 (if (memq (key-binding key t) '(gnus-article-read-summary-keys
6871 gnus-article-read-summary-send-keys))
6872 (with-current-buffer gnus-article-current-summary
6873 (setq unread-command-events
6874 (if (featurep 'xemacs)
6875 (append key nil)
6876 (mapcar (lambda (x) (if (and (integerp x) (>= x 128))
6877 (list 'meta (- x 128))
6878 x))
6879 key)))
6880 (let ((cursor-in-echo-area t)
6881 gnus-pick-mode)
6882 (describe-key-briefly (read-key-sequence nil t) insert)))
6883 (describe-key-briefly key insert)))
6885 ;;`gnus-agent-mode' in gnus-agent.el will define it.
6886 (defvar gnus-agent-summary-mode)
6887 (defvar gnus-draft-mode)
6888 (defvar help-xref-stack-item)
6890 (defun gnus-article-describe-bindings (&optional prefix)
6891 "Show a list of all defined keys, and their definitions.
6892 The optional argument PREFIX, if non-nil, should be a key sequence;
6893 then we display only bindings that start with that prefix."
6894 (interactive)
6895 (gnus-article-check-buffer)
6896 (let ((keymap (copy-keymap gnus-article-mode-map))
6897 (map (copy-keymap gnus-article-send-map))
6898 (sumkeys (where-is-internal 'gnus-article-read-summary-keys))
6899 parent agent draft)
6900 (define-key keymap "S" map)
6901 (define-key map [t] nil)
6902 (with-current-buffer gnus-article-current-summary
6903 (set-keymap-parent
6904 keymap
6905 (if (setq parent (keymap-parent gnus-article-mode-map))
6906 (prog1
6907 (setq parent (copy-keymap parent))
6908 (set-keymap-parent parent (current-local-map)))
6909 (current-local-map)))
6910 (set-keymap-parent map (key-binding "S"))
6911 (let (key def gnus-pick-mode)
6912 (while sumkeys
6913 (setq key (pop sumkeys))
6914 (cond ((and (vectorp key) (= (length key) 1)
6915 (consp (setq def (aref key 0)))
6916 (numberp (car def)) (numberp (cdr def)))
6917 (when (< (max (car def) (cdr def)) 128)
6918 (setq sumkeys
6919 (append (mapcar
6920 #'vector
6921 (nreverse (gnus-uncompress-range def)))
6922 sumkeys))))
6923 ((setq def (key-binding key))
6924 (unless (eq def 'undefined)
6925 (define-key keymap key def))))))
6926 (when (boundp 'gnus-agent-summary-mode)
6927 (setq agent gnus-agent-summary-mode))
6928 (when (boundp 'gnus-draft-mode)
6929 (setq draft gnus-draft-mode)))
6930 (with-temp-buffer
6931 (use-local-map keymap)
6932 (set (make-local-variable 'gnus-agent-summary-mode) agent)
6933 (set (make-local-variable 'gnus-draft-mode) draft)
6934 (describe-bindings prefix))
6935 (let ((item `((lambda (prefix)
6936 (with-current-buffer ,(current-buffer)
6937 (gnus-article-describe-bindings prefix)))
6938 ,prefix)))
6939 ;; Loading `help-mode' here is necessary if `describe-bindings'
6940 ;; is replaced with something, e.g. `helm-descbinds'.
6941 (require 'help-mode)
6942 (with-current-buffer (let (help-xref-following) (help-buffer))
6943 (setq help-xref-stack-item item)))))
6945 (defun gnus-article-reply-with-original (&optional wide)
6946 "Start composing a reply mail to the current message.
6947 The text in the region will be yanked. If the region isn't active,
6948 the entire article will be yanked."
6949 (interactive)
6950 (let ((article (cdr gnus-article-current))
6951 contents)
6952 (if (not (gnus-region-active-p))
6953 (with-current-buffer gnus-summary-buffer
6954 (gnus-summary-reply (list (list article)) wide))
6955 (setq contents (buffer-substring (point) (mark t)))
6956 ;; Deactivate active regions.
6957 (when (and (boundp 'transient-mark-mode)
6958 transient-mark-mode)
6959 (setq mark-active nil))
6960 (with-current-buffer gnus-summary-buffer
6961 (gnus-summary-reply
6962 (list (list article contents)) wide)))))
6964 (defun gnus-article-wide-reply-with-original ()
6965 "Start composing a wide reply mail to the current message.
6966 The text in the region will be yanked. If the region isn't active,
6967 the entire article will be yanked."
6968 (interactive)
6969 (gnus-article-reply-with-original t))
6971 (defun gnus-article-followup-with-original ()
6972 "Compose a followup to the current article.
6973 The text in the region will be yanked. If the region isn't active,
6974 the entire article will be yanked."
6975 (interactive)
6976 (let ((article (cdr gnus-article-current))
6977 contents)
6978 (if (not (gnus-region-active-p))
6979 (with-current-buffer gnus-summary-buffer
6980 (gnus-summary-followup (list (list article))))
6981 (setq contents (buffer-substring (point) (mark t)))
6982 ;; Deactivate active regions.
6983 (when (and (boundp 'transient-mark-mode)
6984 transient-mark-mode)
6985 (setq mark-active nil))
6986 (with-current-buffer gnus-summary-buffer
6987 (gnus-summary-followup
6988 (list (list article contents)))))))
6990 (defun gnus-article-hide (&optional arg force)
6991 "Hide all the gruft in the current article.
6992 This means that signatures, cited text and (some) headers will be
6993 hidden.
6994 If given a prefix, show the hidden text instead."
6995 (interactive (append (gnus-article-hidden-arg) (list 'force)))
6996 (gnus-article-hide-headers arg)
6997 (gnus-article-hide-list-identifiers arg)
6998 (gnus-article-hide-citation-maybe arg force)
6999 (gnus-article-hide-signature arg))
7001 (defun gnus-check-group-server ()
7002 ;; Make sure the connection to the server is alive.
7003 (unless (gnus-server-opened
7004 (gnus-find-method-for-group gnus-newsgroup-name))
7005 (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name))
7006 (gnus-request-group gnus-newsgroup-name t)))
7008 (eval-when-compile
7009 (autoload 'nneething-get-file-name "nneething"))
7011 (defun gnus-request-article-this-buffer (article group)
7012 "Get an article and insert it into this buffer."
7013 (let (do-update-line sparse-header)
7014 (prog1
7015 (save-excursion
7016 (erase-buffer)
7017 (gnus-kill-all-overlays)
7018 (setq group (or group gnus-newsgroup-name))
7020 ;; Using `gnus-request-article' directly will insert the article into
7021 ;; `nntp-server-buffer' - so we'll save some time by not having to
7022 ;; copy it from the server buffer into the article buffer.
7024 ;; We only request an article by message-id when we do not have the
7025 ;; headers for it, so we'll have to get those.
7026 (when (stringp article)
7027 (gnus-read-header article))
7029 ;; If the article number is negative, that means that this article
7030 ;; doesn't belong in this newsgroup (possibly), so we find its
7031 ;; message-id and request it by id instead of number.
7032 (when (and (numberp article)
7033 gnus-summary-buffer
7034 (get-buffer gnus-summary-buffer)
7035 (gnus-buffer-exists-p gnus-summary-buffer))
7036 (with-current-buffer gnus-summary-buffer
7037 (let ((header (gnus-summary-article-header article)))
7038 (when (< article 0)
7039 (cond
7040 ((memq article gnus-newsgroup-sparse)
7041 ;; This is a sparse gap article.
7042 (setq do-update-line article)
7043 (setq article (mail-header-id header))
7044 (setq sparse-header (gnus-read-header article))
7045 (setq gnus-newsgroup-sparse
7046 (delq article gnus-newsgroup-sparse)))
7047 ((vectorp header)
7048 ;; It's a real article.
7049 (setq article (mail-header-id header)))
7050 (t
7051 ;; It is an extracted pseudo-article.
7052 (setq article 'pseudo)
7053 (gnus-request-pseudo-article header))))
7055 (let ((method (gnus-find-method-for-group
7056 gnus-newsgroup-name)))
7057 (when (and (eq (car method) 'nneething)
7058 (vectorp header))
7059 (let ((dir (nneething-get-file-name
7060 (mail-header-id header))))
7061 (when (and (stringp dir)
7062 (file-directory-p dir))
7063 (setq article 'nneething)
7064 (gnus-group-enter-directory dir))))))))
7066 (cond
7067 ;; Refuse to select canceled articles.
7068 ((and (numberp article)
7069 gnus-summary-buffer
7070 (get-buffer gnus-summary-buffer)
7071 (gnus-buffer-exists-p gnus-summary-buffer)
7072 (eq (cdr (with-current-buffer gnus-summary-buffer
7073 (assq article gnus-newsgroup-reads)))
7074 gnus-canceled-mark))
7075 nil)
7076 ;; We first check `gnus-original-article-buffer'.
7077 ((and (get-buffer gnus-original-article-buffer)
7078 (numberp article)
7079 (with-current-buffer gnus-original-article-buffer
7080 (and (equal (car gnus-original-article) group)
7081 (eq (cdr gnus-original-article) article))))
7082 ;; `insert-buffer-substring' would incorrectly use the
7083 ;; equivalent of string-make-multibyte which amount to decoding
7084 ;; with locale-coding-system, causing failure of
7085 ;; subsequent decoding.
7086 (insert (mm-string-to-multibyte
7087 (with-current-buffer gnus-original-article-buffer
7088 (buffer-substring (point-min) (point-max)))))
7089 'article)
7090 ;; Check the backlog.
7091 ((and gnus-keep-backlog
7092 (gnus-backlog-request-article group article (current-buffer)))
7093 'article)
7094 ;; Check asynchronous pre-fetch.
7095 ((gnus-async-request-fetched-article group article (current-buffer))
7096 (gnus-async-prefetch-next group article gnus-summary-buffer)
7097 (when (and (numberp article) gnus-keep-backlog)
7098 (gnus-backlog-enter-article group article (current-buffer)))
7099 'article)
7100 ;; Check the cache.
7101 ((and gnus-use-cache
7102 (numberp article)
7103 (gnus-cache-request-article article group))
7104 'article)
7105 ;; Check the agent cache.
7106 ((gnus-agent-request-article article group)
7107 'article)
7108 ;; Get the article and put into the article buffer.
7109 ((or (stringp article)
7110 (numberp article))
7111 (let ((gnus-override-method gnus-override-method)
7112 (methods (and (stringp article)
7113 (with-current-buffer gnus-summary-buffer
7114 (gnus-refer-article-methods))))
7115 (backend (car (gnus-find-method-for-group
7116 gnus-newsgroup-name)))
7117 result
7118 (inhibit-read-only t))
7119 (when (and (null gnus-override-method)
7120 methods)
7121 (setq gnus-override-method (pop methods)))
7122 (while (not result)
7123 (erase-buffer)
7124 (gnus-kill-all-overlays)
7125 (let ((gnus-newsgroup-name group))
7126 (gnus-check-group-server))
7127 (cond
7128 ((gnus-request-article article group (current-buffer))
7129 (when (numberp article)
7130 (gnus-async-prefetch-next group article
7131 gnus-summary-buffer)
7132 (when gnus-keep-backlog
7133 (gnus-backlog-enter-article
7134 group article (current-buffer)))
7135 (when (and gnus-agent
7136 (gnus-agent-group-covered-p group))
7137 (gnus-agent-store-article article group)))
7138 (setq result 'article))
7139 (methods
7140 (setq gnus-override-method (pop methods)))
7141 ((not (string-match "^400 "
7142 (nnheader-get-report backend)))
7143 ;; If we get 400 server disconnect, reconnect and
7144 ;; retry; otherwise, assume the article has expired.
7145 (setq result 'done))))
7146 (and (eq result 'article) 'article)))
7147 ;; It was a pseudo.
7148 (t article)))
7150 ;; Associate this article with the current summary buffer.
7151 (setq gnus-article-current-summary gnus-summary-buffer)
7153 ;; Take the article from the original article buffer
7154 ;; and place it in the buffer it's supposed to be in.
7155 (when (and (get-buffer gnus-article-buffer)
7156 (equal (buffer-name (current-buffer))
7157 (buffer-name (get-buffer gnus-article-buffer))))
7158 (save-excursion
7159 (if (get-buffer gnus-original-article-buffer)
7160 (set-buffer gnus-original-article-buffer)
7161 (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
7162 (buffer-disable-undo)
7163 (setq major-mode 'gnus-original-article-mode)
7164 (setq buffer-read-only t))
7165 (let ((inhibit-read-only t))
7166 (erase-buffer)
7167 (insert-buffer-substring gnus-article-buffer))
7168 (setq gnus-original-article (cons group article)))
7170 ;; Decode charsets.
7171 (run-hooks 'gnus-article-decode-hook)
7172 ;; Mark article as decoded or not.
7173 (setq gnus-article-decoded-p gnus-article-decode-hook))
7175 ;; Update sparse articles.
7176 (when (and do-update-line
7177 (or (numberp article)
7178 (stringp article)))
7179 (let ((buf (current-buffer)))
7180 (set-buffer gnus-summary-buffer)
7181 (gnus-summary-update-article do-update-line sparse-header)
7182 (gnus-summary-goto-subject do-update-line nil t)
7183 (set-window-point (gnus-get-buffer-window (current-buffer) t)
7184 (point))
7185 (set-buffer buf))))))
7187 (defun gnus-block-private-groups (group)
7188 (if (or (gnus-news-group-p group)
7189 (gnus-member-of-valid 'global group))
7190 ;; Block nothing in news groups.
7191 nil
7192 ;; Block everything anywhere else.
7193 "."))
7195 (defun gnus-blocked-images ()
7196 (if (functionp gnus-blocked-images)
7197 (funcall gnus-blocked-images gnus-newsgroup-name)
7198 gnus-blocked-images))
7200 ;;;
7201 ;;; Article editing
7202 ;;;
7204 (defcustom gnus-article-edit-mode-hook nil
7205 "Hook run in article edit mode buffers."
7206 :group 'gnus-article-various
7207 :type 'hook)
7209 (defvar gnus-article-edit-done-function nil)
7211 (defvar gnus-article-edit-mode-map nil)
7213 ;; Should we be using derived.el for this?
7214 (unless gnus-article-edit-mode-map
7215 (setq gnus-article-edit-mode-map (make-keymap))
7216 (set-keymap-parent gnus-article-edit-mode-map text-mode-map)
7218 (gnus-define-keys gnus-article-edit-mode-map
7219 "\C-c?" describe-mode
7220 "\C-c\C-c" gnus-article-edit-done
7221 "\C-c\C-k" gnus-article-edit-exit
7222 "\C-c\C-f\C-t" message-goto-to
7223 "\C-c\C-f\C-o" message-goto-from
7224 "\C-c\C-f\C-b" message-goto-bcc
7225 ;;"\C-c\C-f\C-w" message-goto-fcc
7226 "\C-c\C-f\C-c" message-goto-cc
7227 "\C-c\C-f\C-s" message-goto-subject
7228 "\C-c\C-f\C-r" message-goto-reply-to
7229 "\C-c\C-f\C-n" message-goto-newsgroups
7230 "\C-c\C-f\C-d" message-goto-distribution
7231 "\C-c\C-f\C-f" message-goto-followup-to
7232 "\C-c\C-f\C-m" message-goto-mail-followup-to
7233 "\C-c\C-f\C-k" message-goto-keywords
7234 "\C-c\C-f\C-u" message-goto-summary
7235 "\C-c\C-f\C-i" message-insert-or-toggle-importance
7236 "\C-c\C-f\C-a" message-generate-unsubscribed-mail-followup-to
7237 "\C-c\C-b" message-goto-body
7238 "\C-c\C-i" message-goto-signature
7240 "\C-c\C-t" message-insert-to
7241 "\C-c\C-n" message-insert-newsgroups
7242 "\C-c\C-o" message-sort-headers
7243 "\C-c\C-e" message-elide-region
7244 "\C-c\C-v" message-delete-not-region
7245 "\C-c\C-z" message-kill-to-signature
7247 "\C-c\C-a" mml-attach-file
7248 "\C-a" message-beginning-of-line
7250 "\M-;" comment-region)
7252 (gnus-define-keys (gnus-article-edit-wash-map
7253 "\C-c\C-w" gnus-article-edit-mode-map)
7254 "f" gnus-article-edit-full-stops))
7256 (easy-menu-define
7257 gnus-article-edit-mode-field-menu gnus-article-edit-mode-map ""
7258 '("Field"
7259 ["Fetch To" message-insert-to t]
7260 ["Fetch Newsgroups" message-insert-newsgroups t]
7261 "----"
7262 ["To" message-goto-to t]
7263 ["From" message-goto-from t]
7264 ["Subject" message-goto-subject t]
7265 ["Cc" message-goto-cc t]
7266 ["Reply-To" message-goto-reply-to t]
7267 ["Summary" message-goto-summary t]
7268 ["Keywords" message-goto-keywords t]
7269 ["Newsgroups" message-goto-newsgroups t]
7270 ["Followup-To" message-goto-followup-to t]
7271 ["Mail-Followup-To" message-goto-mail-followup-to t]
7272 ["Distribution" message-goto-distribution t]
7273 ["Body" message-goto-body t]
7274 ["Signature" message-goto-signature t]))
7276 (define-derived-mode gnus-article-edit-mode message-mode "Article Edit"
7277 "Major mode for editing articles.
7278 This is an extended text-mode.
7281 (make-local-variable 'gnus-article-edit-done-function)
7282 (make-local-variable 'gnus-prev-winconf)
7283 (set (make-local-variable 'font-lock-defaults)
7284 '(message-font-lock-keywords t))
7285 (set (make-local-variable 'mail-header-separator) "")
7286 (set (make-local-variable 'gnus-article-edit-mode) t)
7287 (easy-menu-add message-mode-field-menu message-mode-map)
7288 (mml-mode)
7289 (setq buffer-read-only nil)
7290 (buffer-enable-undo)
7291 (widen))
7293 (defun gnus-article-edit (&optional force)
7294 "Edit the current article.
7295 This will have permanent effect only in mail groups.
7296 If FORCE is non-nil, allow editing of articles even in read-only
7297 groups."
7298 (interactive "P")
7299 (when (and (not force)
7300 (gnus-group-read-only-p))
7301 (error "The current newsgroup does not support article editing"))
7302 (gnus-article-date-original)
7303 (gnus-article-edit-article
7304 'ignore
7305 `(lambda (no-highlight)
7306 'ignore
7307 (gnus-summary-edit-article-done
7308 ,(or (mail-header-references gnus-current-headers) "")
7309 ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight))))
7311 (defun gnus-article-edit-article (start-func exit-func &optional quiet)
7312 "Start editing the contents of the current article buffer."
7313 (let ((winconf (current-window-configuration)))
7314 (set-buffer gnus-article-buffer)
7315 (let ((message-auto-save-directory
7316 ;; Don't associate the article buffer with a draft file.
7317 nil))
7318 (gnus-article-edit-mode))
7319 (funcall start-func)
7320 (set-buffer-modified-p nil)
7321 (gnus-configure-windows 'edit-article)
7322 (setq gnus-article-edit-done-function exit-func)
7323 (setq gnus-prev-winconf winconf)
7324 (unless quiet
7325 (gnus-message 6 "C-c C-c to end edits"))))
7327 (defun gnus-article-edit-done (&optional arg)
7328 "Update the article edits and exit."
7329 (interactive "P")
7330 (let ((func gnus-article-edit-done-function)
7331 (buf (current-buffer))
7332 (start (window-start))
7333 (p (point))
7334 (winconf gnus-prev-winconf))
7335 (widen) ;; Widen it in case that users narrowed the buffer.
7336 (funcall func arg)
7337 (set-buffer buf)
7338 ;; The cache and backlog have to be flushed somewhat.
7339 (when gnus-keep-backlog
7340 (gnus-backlog-remove-article
7341 (car gnus-article-current) (cdr gnus-article-current)))
7342 ;; Flush original article as well.
7343 (gnus-flush-original-article-buffer)
7344 (when gnus-use-cache
7345 (gnus-cache-update-article
7346 (car gnus-article-current) (cdr gnus-article-current)))
7347 ;; We remove all text props from the article buffer.
7348 (kill-all-local-variables)
7349 (set-text-properties (point-min) (point-max) nil)
7350 (gnus-article-mode)
7351 (set-window-configuration winconf)
7352 (set-buffer buf)
7353 (set-window-start (get-buffer-window buf) start)
7354 (set-window-point (get-buffer-window buf) (point)))
7355 (gnus-summary-show-article))
7357 (defun gnus-flush-original-article-buffer ()
7358 (when (get-buffer gnus-original-article-buffer)
7359 (with-current-buffer gnus-original-article-buffer
7360 (setq gnus-original-article nil))))
7362 (defun gnus-article-edit-exit ()
7363 "Exit the article editing without updating."
7364 (interactive)
7365 (when (or (not (buffer-modified-p))
7366 (yes-or-no-p "Article modified; kill anyway? "))
7367 (let ((curbuf (current-buffer))
7368 (p (point))
7369 (window-start (window-start)))
7370 (erase-buffer)
7371 (if (gnus-buffer-live-p gnus-original-article-buffer)
7372 (insert-buffer-substring gnus-original-article-buffer))
7373 (let ((winconf gnus-prev-winconf))
7374 (kill-all-local-variables)
7375 (gnus-article-mode)
7376 (set-window-configuration winconf)
7377 ;; Tippy-toe some to make sure that point remains where it was.
7378 (save-current-buffer
7379 (set-buffer curbuf)
7380 (set-window-start (get-buffer-window (current-buffer)) window-start)
7381 (goto-char p))))
7382 (gnus-summary-show-article)))
7384 (defun gnus-article-edit-full-stops ()
7385 "Interactively repair spacing at end of sentences."
7386 (interactive)
7387 (save-excursion
7388 (goto-char (point-min))
7389 (search-forward-regexp "^$" nil t)
7390 (let ((case-fold-search nil))
7393 ;;;
7394 ;;; Article highlights
7395 ;;;
7397 ;; Written by Per Abrahamsen <abraham@iesd.auc.dk>.
7399 ;;; Internal Variables:
7401 (defcustom gnus-button-url-regexp
7402 (concat
7406 (if (string-match "[[:digit:]]" "1") ;; Support POSIX?
7408 (punct "!?:;.,"))
7409 (concat
7411 ;; Match paired parentheses, e.g. in Wikipedia URLs:
7412 ;; http://thread.gmane.org/47B4E3B2.3050402@gmail.com
7413 "[" chars punct "]+" "(" "[" chars punct "]+" "[" chars "]*)"
7416 "[" chars punct "]+" "[" chars "]"
7418 (concat ;; XEmacs 21.4 doesn't support POSIX.
7422 "Regular expression that matches URLs."
7423 :version "24.4"
7424 :group 'gnus-article-buttons
7425 :type 'regexp)
7427 (defcustom gnus-button-valid-fqdn-regexp
7428 message-valid-fqdn-regexp
7429 "Regular expression that matches a valid FQDN."
7430 :version "22.1"
7431 :group 'gnus-article-buttons
7432 :type 'regexp)
7434 ;; Regexp suggested by Felix Wiemann in <87oeuomcz9.fsf@news2.ososo.de>
7435 (defcustom gnus-button-valid-localpart-regexp
7437 "Regular expression that matches a localpart of mail addresses or MIDs."
7438 :version "22.1"
7439 :group 'gnus-article-buttons
7440 :type 'regexp)
7442 (defcustom gnus-button-man-handler 'manual-entry
7443 "Function to use for displaying man pages.
7444 The function must take at least one argument with a string naming the
7445 man page."
7446 :version "22.1"
7447 :type '(choice (function-item :tag "Man" manual-entry)
7448 (function-item :tag "Woman" woman)
7449 (function :tag "Other"))
7450 :group 'gnus-article-buttons)
7452 (defcustom gnus-button-mid-or-mail-regexp
7454 gnus-button-valid-fqdn-regexp
7456 "Regular expression that matches a message ID or a mail address."
7457 :version "22.1"
7458 :group 'gnus-article-buttons
7459 :type 'regexp)
7461 (defcustom gnus-button-prefer-mid-or-mail 'gnus-button-mid-or-mail-heuristic
7463 Strings like this can be either a message ID or a mail address. If it is one
7464 of the symbols `mid' or `mail', Gnus will always assume that the string is a
7465 message ID or a mail address, respectively. If this variable is set to the
7466 symbol `ask', always query the user what do do. If it is a function, this
7467 function will be called with the string as its only argument. The function
7468 must return `mid', `mail', `invalid' or `ask'."
7469 :version "22.1"
7470 :group 'gnus-article-buttons
7471 :type '(choice (function-item :tag "Heuristic function"
7472 gnus-button-mid-or-mail-heuristic)
7473 (const ask)
7474 (const mid)
7475 (const mail)))
7477 (defcustom gnus-button-mid-or-mail-heuristic-alist
7479 (-10.0 . "#")
7482 (-5.0 . "@[Nn][Ee][Ww][Ss]") ;; /\@news/i
7483 (-5.0 . "@.*[Dd][Ii][Aa][Ll][Uu][Pp]") ;; /\@.*dialup/i;
7484 (-1.0 . "^[^a-z]+@")
7485 ;;
7487 (-5.0 . "[a-z].*[A-Z].*[a-z].*[A-Z].*@") ;; "([a-z].*[A-Z].*){2,}\@"
7488 (-3.0 . "[A-Z][A-Z][a-z][a-z].*@")
7490 ;;
7491 (-2.0 . "^[0-9]")
7492 (-1.0 . "^[0-9][0-9]")
7493 ;;
7494 ;; -3.0 /^[0-9][0-9a-fA-F]{2,2}/;
7495 (-3.0 . "^[0-9][0-9a-fA-F][0-9a-fA-F][^0-9a-fA-F]")
7496 ;; -5.0 /^[0-9][0-9a-fA-F]{3,3}/;
7497 (-5.0 . "^[0-9][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][^0-9a-fA-F]")
7498 ;;
7499 (-3.0 . "[0-9][0-9][0-9][0-9][0-9][^0-9].*@") ;; "[0-9]{5,}.*\@"
7500 (-3.0 . "[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][^0-9].*@")
7501 ;; "[0-9]{8,}.*\@"
7502 (-3.0
7503 . "[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9].*@")
7504 ;; "[0-9]{12,}.*\@"
7505 ;; compensation for TDMA dated mail addresses:
7506 (25.0 . "-dated-[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]+.*@")
7507 ;;
7509 (-20.0 . "^slrn")
7510 (-20.0 . "^Pine")
7512 (-20.0 . "_-_") ;; Subject change in thread
7513 ;;
7517 ;;
7518 ;; (5.0 . "") ;; $local_part_len <= 7
7519 (10.0 . "^[^0-9]+@")
7520 (3.0 . "^[^0-9]+[0-9][0-9]?[0-9]?@")
7521 ;; ^[^0-9]+[0-9]{1,3}\@ digits only at end of local part
7522 (3.0 . "\@stud")
7523 ;;
7524 (2.0 . "[a-z][a-z][._-][A-Z][a-z].*@")
7525 ;;
7526 (0.5 . "^[A-Z][a-z]")
7527 (0.5 . "^[A-Z][a-z][a-z]")
7528 (1.5 . "^[A-Z][a-z][A-Z][a-z][^a-z]") ;; ^[A-Z][a-z]{3,3}
7529 (2.0 . "^[A-Z][a-z][A-Z][a-z][a-z][^a-z]")) ;; ^[A-Z][a-z]{4,4}
7530 "An alist of \(RATE . REGEXP\) pairs for `gnus-button-mid-or-mail-heuristic'.
7532 A negative RATE indicates a message IDs, whereas a positive indicates a mail
7533 address. The REGEXP is processed with `case-fold-search' set to nil."
7534 :version "22.1"
7535 :group 'gnus-article-buttons
7536 :type '(repeat (cons (number :tag "Rate")
7537 (regexp :tag "Regexp"))))
7539 (defun gnus-button-mid-or-mail-heuristic (mid-or-mail)
7540 "Guess whether MID-OR-MAIL is a message ID or a mail address.
7541 Returns `mid' if MID-OR-MAIL is a message IDs, `mail' if it's a mail
7542 address, `ask' if unsure and `invalid' if the string is invalid."
7543 (let ((case-fold-search nil)
7544 (list gnus-button-mid-or-mail-heuristic-alist)
7545 (result 0) rate regexp lpartlen elem)
7546 (setq lpartlen
7548 (gnus-message 8 "`%s', length of local part=`%s'." mid-or-mail lpartlen)
7549 ;; Certain special cases...
7550 (when (string-match
7551 (concat
7555 mid-or-mail)
7556 (gnus-message 8 "`%s' is a known mail address." mid-or-mail)
7557 (setq result 'mail))
7559 (gnus-message 8 "`%s' is invalid." mid-or-mail)
7560 (setq result 'invalid))
7561 ;; Nothing more to do, if result is not a number here...
7562 (when (numberp result)
7563 (while list
7564 (setq elem (car list)
7565 rate (car elem)
7566 regexp (cdr elem)
7567 list (cdr list))
7568 (when (string-match regexp mid-or-mail)
7569 (setq result (+ result rate))
7570 (gnus-message
7571 9 "`%s' matched `%s', rate `%s', result `%s'."
7572 mid-or-mail regexp rate result)))
7573 (when (<= lpartlen 7)
7574 (setq result (+ result 5.0))
7575 (gnus-message 9 "`%s' matched (<= lpartlen 7), result `%s'."
7576 mid-or-mail result))
7577 (when (>= lpartlen 12)
7578 (gnus-message 9 "`%s' matched (>= lpartlen 12)" mid-or-mail)
7579 (cond
7580 ((string-match "[0-9][^0-9]+[0-9].*@" mid-or-mail)
7581 ;; Long local part should contain realname if e-mail address,
7582 ;; too many digits: message-id.
7583 ;; $score -= 5.0 + 0.1 * $local_part_len;
7584 (setq rate (* -1.0 (+ 5.0 (* 0.1 lpartlen))))
7585 (setq result (+ result rate))
7586 (gnus-message
7587 9 "Many digits in `%s', rate `%s', result `%s'."
7588 mid-or-mail rate result))
7589 ((string-match "[^aeiouy][^aeiouy][^aeiouy][^aeiouy]+.*\@"
7590 mid-or-mail)
7591 ;; Too few vowels [^aeiouy]{4,}.*\@
7592 (setq result (+ result -5.0))
7593 (gnus-message
7594 9 "Few vowels in `%s', rate `%s', result `%s'."
7595 mid-or-mail -5.0 result))
7596 (t
7597 (setq result (+ result 5.0))
7598 (gnus-message
7599 9 "`%s', rate `%s', result `%s'." mid-or-mail 5.0 result)))))
7600 (gnus-message 8 "`%s': Final rate is `%s'." mid-or-mail result)
7601 ;; Maybe we should make this a customizable alist: (condition . 'result)
7602 (cond
7603 ((symbolp result) result)
7604 ;; Now convert number into proper results:
7605 ((< result -10.0) 'mid)
7606 ((> result 10.0) 'mail)
7607 (t 'ask))))
7609 (defun gnus-button-handle-mid-or-mail (mid-or-mail)
7610 (let* ((pref gnus-button-prefer-mid-or-mail) guessed
7611 (url-mid (concat "news" ":" mid-or-mail))
7612 (url-mailto (concat "mailto" ":" mid-or-mail)))
7613 (gnus-message 9 "mid-or-mail=%s" mid-or-mail)
7614 (when (fboundp pref)
7615 (setq guessed
7616 ;; get rid of surrounding angles...
7617 (funcall pref
7619 (if (or (eq 'mid guessed) (eq 'mail guessed))
7620 (setq pref guessed)
7621 (setq pref 'ask)))
7622 (if (eq pref 'ask)
7623 (save-window-excursion
7624 (if (y-or-n-p (concat "Is <" mid-or-mail "> a mail address? "))
7625 (setq pref 'mail)
7626 (setq pref 'mid))))
7627 (cond ((eq pref 'mid)
7628 (gnus-message 8 "calling `gnus-button-handle-news' %s" url-mid)
7629 (gnus-button-handle-news url-mid))
7630 ((eq pref 'mail)
7631 (gnus-message 8 "calling `gnus-url-mailto' %s" url-mailto)
7632 (gnus-url-mailto url-mailto))
7633 (t (gnus-message 3 "Invalid string.")))))
7635 (defun gnus-button-handle-custom (fun arg)
7636 "Call function FUN on argument ARG.
7637 Both FUN and ARG are supposed to be strings. ARG will be passed
7638 as a symbol to FUN."
7639 (funcall (intern fun)
7640 (if (string-match "^customize-apropos" fun)
7641 arg
7642 (intern arg))))
7646 (defun gnus-button-handle-describe-function (url)
7647 "Call `describe-function' when pushing the corresponding URL button."
7648 (describe-function
7649 (intern
7650 (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))))
7652 (defun gnus-button-handle-describe-variable (url)
7653 "Call `describe-variable' when pushing the corresponding URL button."
7654 (describe-variable
7655 (intern
7656 (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))))
7658 (defun gnus-button-handle-symbol (url)
7659 "Display help on variable or function.
7660 Calls `describe-variable' or `describe-function'."
7661 (let ((sym (intern url)))
7662 (cond
7663 ((fboundp sym) (describe-function sym))
7664 ((boundp sym) (describe-variable sym))
7665 (t (gnus-message 3 "`%s' is not a known function of variable." url)))))
7667 (defun gnus-button-handle-describe-key (url)
7668 "Call `describe-key' when pushing the corresponding URL button."
7669 (let* ((key-string
7670 (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))
7671 (keys (ignore-errors (eval `(kbd ,key-string)))))
7672 (if keys
7673 (describe-key keys)
7674 (gnus-message 3 "Invalid key sequence in button: %s" key-string))))
7676 (defun gnus-button-handle-apropos (url)
7677 "Call `apropos' when pushing the corresponding URL button."
7678 (apropos (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))
7680 (defun gnus-button-handle-apropos-command (url)
7681 "Call `apropos' when pushing the corresponding URL button."
7682 (apropos-command
7683 (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))
7685 (defun gnus-button-handle-apropos-variable (url)
7686 "Call `apropos' when pushing the corresponding URL button."
7687 (funcall
7688 (if (fboundp 'apropos-variable) 'apropos-variable 'apropos)
7689 (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))
7691 (defun gnus-button-handle-apropos-documentation (url)
7692 "Call `apropos' when pushing the corresponding URL button."
7693 (funcall
7694 (if (fboundp 'apropos-documentation) 'apropos-documentation 'apropos)
7695 (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))
7697 (defun gnus-button-handle-library (url)
7698 "Call `locate-library' when pushing the corresponding URL button."
7699 (gnus-message 9 "url=`%s'" url)
7700 (let* ((lib (locate-library url))
7701 (file (gnus-replace-in-string (or lib "") "\.elc" ".el")))
7702 (if (not lib)
7703 (gnus-message 1 "Cannot locale library `%s'." url)
7704 (find-file-read-only file))))
7706 (defcustom gnus-button-man-level 5
7707 "*Integer that says how many man-related buttons Gnus will show.
7708 The higher the number, the more buttons will appear and the more false
7709 positives are possible. Note that you can set this variable local to
7710 specific groups. Setting it higher in Unix groups is probably a good idea.
7711 See Info node `(gnus)Group Parameters' and the variable `gnus-parameters' on
7712 how to set variables in specific groups."
7713 :version "22.1"
7714 :group 'gnus-article-buttons
7715 :link '(custom-manual "(gnus)Group Parameters")
7716 :type 'integer)
7718 (defcustom gnus-button-emacs-level 5
7719 "*Integer that says how many emacs-related buttons Gnus will show.
7720 The higher the number, the more buttons will appear and the more false
7721 positives are possible. Note that you can set this variable local to
7722 specific groups. Setting it higher in Emacs or Gnus related groups is
7723 probably a good idea. See Info node `(gnus)Group Parameters' and the variable
7724 `gnus-parameters' on how to set variables in specific groups."
7725 :version "22.1"
7726 :group 'gnus-article-buttons
7727 :link '(custom-manual "(gnus)Group Parameters")
7728 :type 'integer)
7730 (defcustom gnus-button-message-level 5
7731 "*Integer that says how many buttons for news or mail messages will appear.
7732 The higher the number, the more buttons will appear and the more false
7733 positives are possible."
7734 ;; mail addresses, MIDs, URLs for news, ...
7735 :version "22.1"
7736 :group 'gnus-article-buttons
7737 :type 'integer)
7739 (defcustom gnus-button-browse-level 5
7740 "*Integer that says how many buttons for browsing will appear.
7741 The higher the number, the more buttons will appear and the more false
7742 positives are possible."
7743 ;; stuff handled by `browse-url' or `gnus-button-embedded-url'
7744 :version "22.1"
7745 :group 'gnus-article-buttons
7746 :type 'integer)
7748 (defcustom gnus-button-alist
7750 0 (>= gnus-button-message-level 0) gnus-button-handle-news 3)
7753 0 t gnus-button-handle-news 2)
7755 1 (>= gnus-button-message-level 0) gnus-button-fetch-group 5)
7757 0 (>= gnus-button-message-level 0) gnus-button-fetch-group 3)
7758 ;; RFC 2392 (Don't allow `/' in domain part --> CID)
7760 0 (>= gnus-button-message-level 0) gnus-button-message-id 2)
7762 2 (>= gnus-button-message-level 0) gnus-button-message-id 3)
7764 2 (>= gnus-button-message-level 0) gnus-button-message-id 3)
7766 0 (>= gnus-button-message-level 0) gnus-url-mailto 2)
7767 ;; RFC 2368 (The mailto URL scheme)
7769 0 (>= gnus-button-message-level 0) gnus-url-mailto 1)
7771 0 (>= gnus-button-message-level 0) gnus-url-mailto 1)
7772 ;; Info Konqueror style <info:/foo/bar baz>.
7773 ;; Must come before " Gnus home-grown style".
7775 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url 1)
7776 ;; Info, Gnus home-grown style (deprecated) <info://foo/bar+baz>
7778 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url 1)
7779 ;; Info GNOME style <info:foo#bar_baz>
7781 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url-gnome 1)
7782 ;; Info KDE style <info:(foo)bar baz>
7784 1 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url-kde 2)
7786 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url 2)
7787 ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+i[ \t\n]+d?[ \t\n]?m[ \t\n]+[^ ]+ ?[^ ]+[ \t\n]+RET\\([ \t\n]+i[ \t\n]+[^ ]+ ?[^ ]+[ \t\n]+RET\\([ \t\n,]*\\)\\)?"
7788 ;; Info links like `C-h i d m Gnus RET' or `C-h i d m Gnus RET i partial RET'
7789 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-keystrokes 0)
7790 ;; This is custom
7792 (>= gnus-button-emacs-level 1) gnus-button-handle-custom 1 2)
7793 ;; Emacs help commands
7795 ;; regexp doesn't match arguments containing ` '.
7796 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos 1)
7798 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-command 1)
7800 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-variable 1)
7802 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-documentation 1)
7803 ;; The following entries may lead to many false positives so don't enable
7804 ;; them by default (use a high button level).
7806 ;; Exclude [.?] for URLs in gmane.emacs.cvs
7807 1 (>= gnus-button-emacs-level 8) gnus-button-handle-library 1)
7809 1 (>= gnus-button-emacs-level 8) gnus-button-handle-library 1)
7811 0 (>= gnus-button-emacs-level 8) gnus-button-handle-symbol 1)
7813 0 (>= gnus-button-emacs-level 9) gnus-button-handle-symbol 1)
7815 1 (>= gnus-button-emacs-level 7) gnus-button-handle-describe-variable 1)
7817 1 (>= gnus-button-emacs-level 7) gnus-button-handle-describe-function 1)
7819 0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-function 2)
7821 0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-variable 2)
7823 ;; Unlike the other regexps we really have to require quoting
7824 ;; here to determine where it ends.
7825 1 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-key 3)
7826 ;; This is how URLs _should_ be embedded in text (RFC 1738, RFC 2396)...
7828 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1)
7829 ;; RFC 2396 (2.4.3., delims) ...
7831 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1)
7832 ;; Raw URLs.
7833 (gnus-button-url-regexp
7834 0 (>= gnus-button-browse-level 0) browse-url 0)
7835 ;; man pages
7837 0 (and (>= gnus-button-man-level 1) (< gnus-button-man-level 3))
7838 gnus-button-handle-man 1)
7839 ;; more man pages: resolv.conf(5), iso_8859-1(7), xterm(1x)
7841 0 (and (>= gnus-button-man-level 3) (< gnus-button-man-level 5))
7842 gnus-button-handle-man 1)
7843 ;; even more: Apache::PerlRun(3pm), PDL::IO::FastRaw(3pm),
7844 ;; SoWWWAnchor(3iv), XSelectInput(3X11), X(1), X(7)
7846 0 (>= gnus-button-man-level 5) gnus-button-handle-man 1)
7847 ;; Recognizing patches to .el files. This is somewhat obscure,
7848 ;; but considering the percentage of Gnus users who hack Emacs
7849 ;; Lisp files...
7851 (>= gnus-button-message-level 4) gnus-button-patch 1 2)
7853 (>= gnus-button-message-level 4) gnus-button-patch 1 2)
7854 ;; MID or mail: To avoid too many false positives we don't try to catch
7855 ;; all kind of allowed MIDs or mail addresses. Domain part must contain
7856 ;; at least one dot. TLD must contain two or three chars or be a know TLD
7857 ;; (info|name|...). Put this entry near the _end_ of `gnus-button-alist'
7858 ;; so that non-ambiguous entries (see above) match first.
7859 (gnus-button-mid-or-mail-regexp
7860 0 (>= gnus-button-message-level 5) gnus-button-handle-mid-or-mail 1))
7861 "*Alist of regexps matching buttons in article bodies.
7863 Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where
7864 REGEXP: is the string (case insensitive) matching text around the button (can
7865 also be Lisp expression evaluating to a string),
7866 BUTTON: is the number of the regexp grouping actually matching the button,
7867 FORM: is a Lisp expression which must eval to true for the button to
7868 be added,
7869 CALLBACK: is the function to call when the user push this button, and each
7870 PAR: is a number of a regexp grouping whose text will be passed to CALLBACK.
7872 CALLBACK can also be a variable, in that case the value of that
7873 variable it the real callback function."
7874 :group 'gnus-article-buttons
7875 :type '(repeat (list (choice regexp variable sexp)
7876 (integer :tag "Button")
7877 (sexp :tag "Form")
7878 (function :tag "Callback")
7879 (repeat :tag "Par"
7880 :inline t
7881 (integer :tag "Regexp group")))))
7882 (put 'gnus-button-alist 'risky-local-variable t)
7884 (defcustom gnus-header-button-alist
7886 0 (>= gnus-button-message-level 0) gnus-button-message-id 0)
7888 1 (>= gnus-button-message-level 0) gnus-button-reply 1)
7890 0 (>= gnus-button-message-level 0) gnus-msg-mail 0)
7891 ("^X-[Uu][Rr][Ll]:" gnus-button-url-regexp
7892 0 (>= gnus-button-browse-level 0) browse-url 0)
7893 ("^Subject:" gnus-button-url-regexp
7894 0 (>= gnus-button-browse-level 0) browse-url 0)
7895 ("^[^:]+:" gnus-button-url-regexp
7896 0 (>= gnus-button-browse-level 0) browse-url 0)
7897 ("^OpenPGP:.*url=" gnus-button-url-regexp
7898 0 (>= gnus-button-browse-level 0) gnus-button-openpgp 0)
7900 0 (>= gnus-button-message-level 0) gnus-url-mailto 1)
7902 1 (>= gnus-button-message-level 0) gnus-button-message-id 4))
7903 "*Alist of headers and regexps to match buttons in article heads.
7905 This alist is very similar to `gnus-button-alist', except that each
7906 alist has an additional HEADER element first in each entry:
7908 \(HEADER REGEXP BUTTON FORM CALLBACK PAR)
7910 HEADER is a regexp to match a header. For a fuller explanation, see
7911 `gnus-button-alist'."
7912 :group 'gnus-article-buttons
7913 :group 'gnus-article-headers
7914 :type '(repeat (list (regexp :tag "Header")
7915 (choice regexp variable)
7916 (integer :tag "Button")
7917 (sexp :tag "Form")
7918 (function :tag "Callback")
7919 (repeat :tag "Par"
7920 :inline t
7921 (integer :tag "Regexp group")))))
7922 (put 'gnus-header-button-alist 'risky-local-variable t)
7924 ;;; Commands:
7926 (defun gnus-article-push-button (event)
7927 "Check text under the mouse pointer for a callback function.
7928 If the text under the mouse pointer has a `gnus-callback' property,
7929 call it with the value of the `gnus-data' text property."
7930 (interactive "e")
7931 (set-buffer (window-buffer (posn-window (event-start event))))
7932 (let* ((pos (posn-point (event-start event)))
7933 (data (get-text-property pos 'gnus-data))
7934 (fun (get-text-property pos 'gnus-callback)))
7935 (goto-char pos)
7936 (when fun
7937 (funcall fun data))))
7939 (defun gnus-article-press-button ()
7940 "Check text at point for a callback function.
7941 If the text at point has a `gnus-callback' property,
7942 call it with the value of the `gnus-data' text property."
7943 (interactive)
7944 (let ((data (get-text-property (point) 'gnus-data))
7945 (fun (get-text-property (point) 'gnus-callback)))
7946 (when fun
7947 (funcall fun data))))
7949 (defun gnus-article-highlight (&optional force)
7950 "Highlight current article.
7951 This function calls `gnus-article-highlight-headers',
7952 `gnus-article-highlight-citation',
7953 `gnus-article-highlight-signature', and `gnus-article-add-buttons' to
7954 do the highlighting. See the documentation for those functions."
7955 (interactive (list 'force))
7956 (gnus-article-highlight-headers)
7957 (gnus-article-highlight-citation force)
7958 (gnus-article-highlight-signature)
7959 (gnus-article-add-buttons)
7960 (gnus-article-add-buttons-to-head))
7962 (defun gnus-article-highlight-some (&optional force)
7963 "Highlight current article.
7964 This function calls `gnus-article-highlight-headers',
7965 `gnus-article-highlight-signature', and `gnus-article-add-buttons' to
7966 do the highlighting. See the documentation for those functions."
7967 (interactive (list 'force))
7968 (gnus-article-highlight-headers)
7969 (gnus-article-highlight-signature)
7970 (gnus-article-add-buttons))
7972 (defun gnus-article-highlight-headers ()
7973 "Highlight article headers as specified by `gnus-header-face-alist'."
7974 (interactive)
7975 (gnus-with-article-headers
7976 (let (regexp header-face field-face from hpoints fpoints)
7977 (dolist (entry gnus-header-face-alist)
7978 (goto-char (point-min))
7980 (if (string-equal "" (nth 0 entry))
7982 (nth 0 entry))
7984 header-face (nth 1 entry)
7985 field-face (nth 2 entry))
7986 (while (and (re-search-forward regexp nil t)
7987 (not (eobp)))
7988 (beginning-of-line)
7989 (setq from (point))
7990 (unless (search-forward ":" nil t)
7991 (forward-char 1))
7992 (when (and header-face
7993 (not (memq (point) hpoints)))
7994 (push (point) hpoints)
7995 (gnus-put-text-property from (point) 'face header-face))
7996 (when (and field-face
7997 (not (memq (setq from (point)) fpoints)))
7998 (push from fpoints)
8000 (forward-char -2)
8001 (goto-char (point-max)))
8002 (gnus-put-text-property from (point) 'face field-face)))))))
8004 (defun gnus-article-highlight-signature ()
8005 "Highlight the signature in an article.
8006 It does this by highlighting everything after
8007 `gnus-signature-separator' using the face `gnus-signature'."
8008 (interactive)
8009 (gnus-with-article-buffer
8010 (let ((inhibit-point-motion-hooks t))
8011 (save-restriction
8012 (when (and gnus-signature-face
8013 (gnus-article-narrow-to-signature))
8014 (gnus-overlay-put (gnus-make-overlay (point-min) (point-max) nil t)
8015 'face gnus-signature-face)
8016 (widen)
8017 (gnus-article-search-signature)
8018 (let ((start (match-beginning 0))
8019 (end (set-marker (make-marker) (1+ (match-end 0)))))
8020 (gnus-article-add-button start (1- end) 'gnus-signature-toggle
8021 end)))))))
8023 (defun gnus-button-in-region-p (b e prop)
8024 "Say whether PROP exists in the region."
8025 (text-property-not-all b e prop nil))
8027 (defun gnus-article-add-buttons ()
8028 "Find external references in the article and make buttons of them.
8030 specified by `gnus-button-alist'."
8031 (interactive)
8032 (gnus-with-article-buffer
8033 (let ((inhibit-point-motion-hooks t)
8034 (case-fold-search t)
8035 (alist gnus-button-alist)
8036 beg entry regexp)
8037 ;; We skip the headers.
8038 (article-goto-body)
8039 (setq beg (point))
8040 (while (setq entry (pop alist))
8041 (setq regexp (eval (car entry)))
8042 (goto-char beg)
8043 (while (re-search-forward regexp nil t)
8044 (let ((start (match-beginning (nth 1 entry)))
8045 (end (match-end (nth 1 entry)))
8046 (from (match-beginning 0)))
8047 (when (and (eval (nth 2 entry))
8048 (not (gnus-button-in-region-p
8049 start end 'gnus-callback)))
8050 ;; That optional form returned non-nil, so we add the
8051 ;; button.
8052 (setq from (set-marker (make-marker) from))
8053 (unless (and (eq (car entry) 'gnus-button-url-regexp)
8054 (gnus-article-extend-url-button from start end))
8055 (gnus-article-add-button start end
8056 'gnus-button-push (list from entry))
8057 (gnus-put-text-property
8058 start end
8059 'gnus-string (buffer-substring-no-properties
8060 start end))))))))))
8062 (defun gnus-article-extend-url-button (beg start end)
8063 "Extend url button if url is folded into two or more lines.
8064 Return non-nil if button is extended. BEG is a marker that points to
8065 the beginning position of a text containing url. START and END are
8066 the endpoints of a url button before it is extended. The concatenated
8067 url is put as the `gnus-button-url' overlay property on the button."
8068 (let ((opoint (point))
8069 (points (list start end))
8070 url delim regexp)
8071 (prog1
8072 (when (and (progn
8073 (goto-char end)
8075 (progn
8076 (goto-char start)
8077 (string-match
8079 (buffer-substring (point-at-bol) start)))
8080 (progn
8081 (setq url (list (buffer-substring start end))
8083 (beginning-of-line)
8084 (setq regexp (concat
8085 (when (and (looking-at
8086 message-cite-prefix-regexp)
8087 (< (match-end 0) start))
8088 (regexp-quote (match-string 0)))
8089 "\
8092 (while (progn
8093 (forward-line 1)
8094 (and (looking-at regexp)
8095 (prog1
8096 (match-beginning 1)
8097 (push (or (match-string 2)
8098 (match-string 1))
8099 url)
8100 (push (setq end (or (match-end 2)
8101 (match-end 1)))
8102 points)
8103 (push (or (match-beginning 2)
8104 (match-beginning 1))
8105 points)))))
8106 (match-beginning 2)))
8107 (let (gnus-article-mouse-face widget-mouse-face)
8108 (while points
8109 (gnus-article-add-button (pop points) (pop points)
8110 'gnus-button-push
8111 (list beg (assq 'gnus-button-url-regexp
8112 gnus-button-alist)))))
8113 (let ((overlay (gnus-make-overlay start end)))
8114 (gnus-overlay-put overlay 'evaporate t)
8115 (gnus-overlay-put overlay 'gnus-button-url
8116 (list (mapconcat 'identity (nreverse url) "")))
8117 (when gnus-article-mouse-face
8118 (gnus-overlay-put overlay 'mouse-face gnus-article-mouse-face)))
8119 t)
8120 (goto-char opoint))))
8122 ;; Add buttons to the head of an article.
8123 (defun gnus-article-add-buttons-to-head ()
8124 "Add buttons to the head of the article."
8125 (interactive)
8126 (gnus-with-article-headers
8127 (let (beg end)
8128 (dolist (entry gnus-header-button-alist)
8129 ;; Each alist entry.
8130 (goto-char (point-min))
8131 (while (re-search-forward (car entry) nil t)
8132 ;; Each header matching the entry.
8133 (setq beg (match-beginning 0))
8135 (match-beginning 0))
8136 (point-max)))
8137 (goto-char beg)
8138 (while (re-search-forward (eval (nth 1 entry)) end t)
8139 ;; Each match within a header.
8140 (let* ((entry (cdr entry))
8141 (start (match-beginning (nth 1 entry)))
8142 (end (match-end (nth 1 entry)))
8143 (form (nth 2 entry)))
8144 (goto-char (match-end 0))
8145 (when (eval form)
8146 (gnus-article-add-button
8147 start end (nth 3 entry)
8148 (buffer-substring (match-beginning (nth 4 entry))
8149 (match-end (nth 4 entry)))))))
8150 (goto-char end))))))
8152 ;;; External functions:
8154 (defun gnus-article-add-button (from to fun &optional data text)
8155 "Create a button between FROM and TO with callback FUN and data DATA."
8156 (when gnus-article-button-face
8157 (gnus-overlay-put (gnus-make-overlay from to nil t)
8158 'face gnus-article-button-face))
8159 (gnus-add-text-properties
8160 from to
8161 (nconc (and gnus-article-mouse-face
8162 (list gnus-mouse-face-prop gnus-article-mouse-face))
8163 (list 'gnus-callback fun)
8164 (and data (list 'gnus-data data))))
8165 (widget-convert-button 'link from to :action 'gnus-widget-press-button
8166 :help-echo (or text "Follow the link")
8167 :keymap gnus-url-button-map
8168 :button-keymap gnus-widget-button-keymap))
8170 (defun gnus-article-copy-string ()
8171 "Copy the string in the button to the kill ring."
8172 (interactive)
8173 (gnus-article-check-buffer)
8174 (let ((data (get-text-property (point) 'gnus-string)))
8175 (when data
8176 (with-temp-buffer
8177 (insert data)
8178 (copy-region-as-kill (point-min) (point-max))
8179 (message "Copied %s" data)))))
8181 ;;; Internal functions:
8183 (defun gnus-article-set-globals ()
8184 (with-current-buffer gnus-summary-buffer
8185 (gnus-set-global-variables)))
8187 (defun gnus-signature-toggle (end)
8188 (gnus-with-article-buffer
8189 (let ((inhibit-point-motion-hooks t))
8190 (if (text-property-any end (point-max) 'article-type 'signature)
8191 (progn
8192 (gnus-delete-wash-type 'signature)
8193 (gnus-remove-text-properties-when
8194 'article-type 'signature end (point-max)
8195 (cons 'article-type (cons 'signature
8196 gnus-hidden-properties))))
8197 (gnus-add-wash-type 'signature)
8198 (gnus-add-text-properties-when
8199 'article-type nil end (point-max)
8200 (cons 'article-type (cons 'signature
8201 gnus-hidden-properties)))))
8202 (let ((gnus-article-mime-handle-alist-1 gnus-article-mime-handle-alist))
8203 (gnus-set-mode-line 'article))))
8205 (defun gnus-button-push (marker-and-entry)
8206 ;; Push button starting at MARKER.
8207 (save-excursion
8208 (let* ((marker (car marker-and-entry))
8209 (entry (cadr marker-and-entry))
8210 (regexp (car entry))
8211 (inhibit-point-motion-hooks t))
8212 (goto-char marker)
8213 ;; This is obviously true, or something bad is happening :)
8214 ;; But we need it to have the match-data
8215 (when (looking-at (or (if (symbolp regexp)
8216 (symbol-value regexp)
8217 regexp)))
8218 (let ((fun (nth 3 entry))
8219 (args (or (and (eq (car entry) 'gnus-button-url-regexp)
8220 (get-char-property marker 'gnus-button-url))
8221 (mapcar (lambda (group)
8222 (let ((string (match-string group)))
8223 (set-text-properties
8224 0 (length string) nil string)
8225 string))
8226 (nthcdr 4 entry)))))
8228 (cond
8229 ((fboundp fun)
8230 (apply fun args))
8231 ((and (boundp fun)
8232 (fboundp (symbol-value fun)))
8233 (apply (symbol-value fun) args))
8234 (t
8235 (gnus-message 1 "You must define `%S' to use this button"
8236 (cons fun args)))))))))
8238 (defun gnus-parse-news-url (url)
8239 (let (scheme server port group message-id articles)
8240 (with-temp-buffer
8241 (insert url)
8242 (goto-char (point-min))
8244 (setq scheme (match-string 1))
8245 (goto-char (match-end 0)))
8247 (setq server (match-string 1))
8248 (setq port (if (stringp (match-string 3))
8249 (string-to-number (match-string 3))
8250 (match-string 3)))
8251 (goto-char (match-end 0)))
8253 (cond
8255 (setq message-id (match-string 1)))
8257 (setq group (match-string 1)
8258 articles (split-string (match-string 2) "-")))
8260 (setq group (match-string 1)))
8261 (t
8262 (error "Unknown news URL syntax"))))
8263 (list scheme server port group message-id articles)))
8265 (defun gnus-button-handle-news (url)
8266 "Fetch a news URL."
8267 (destructuring-bind (scheme server port group message-id articles)
8268 (gnus-parse-news-url url)
8269 (cond
8270 (message-id
8271 (with-current-buffer gnus-summary-buffer
8272 (if server
8273 (let ((gnus-refer-article-method
8274 (nconc (list (list 'nntp server))
8275 gnus-refer-article-method))
8276 (nntp-port-number (or port "nntp")))
8277 (gnus-message 7 "Fetching %s with %s"
8278 message-id gnus-refer-article-method)
8279 (gnus-summary-refer-article message-id))
8280 (gnus-summary-refer-article message-id))))
8281 (group
8282 (gnus-button-fetch-group url)))))
8284 (defun gnus-button-patch (library line)
8285 "Visit an Emacs Lisp library LIBRARY on line LINE."
8286 (interactive)
8287 (let ((file (locate-library (file-name-nondirectory library))))
8288 (unless file
8289 (error "Couldn't find library %s" library))
8290 (find-file file)
8291 (goto-char (point-min))
8292 (forward-line (1- (string-to-number line)))))
8294 (defun gnus-button-handle-man (url)
8295 "Fetch a man page."
8296 (gnus-message 9 "`%s' `%s'" gnus-button-man-handler url)
8297 (when (eq gnus-button-man-handler 'woman)
8299 (gnus-message 9 "`%s' `%s'" gnus-button-man-handler url)
8300 (funcall gnus-button-man-handler url))
8302 (defun gnus-button-handle-info-url (url)
8303 "Fetch an info URL."
8304 (setq url (mm-subst-char-in-string ?+ ?\ url))
8305 (cond
8307 (gnus-info-find-node
8308 (concat "(" (or (gnus-url-unhex-string (match-string 1 url))
8309 "Gnus")
8310 ")" (gnus-url-unhex-string (match-string 2 url)))))
8312 (setq url
8313 (gnus-replace-in-string
8315 (gnus-info-find-node url))
8316 (t (error "Can't parse %s" url))))
8318 (defun gnus-button-handle-info-url-gnome (url)
8319 "Fetch GNOME style info URL."
8320 (setq url (mm-subst-char-in-string ?_ ?\ url))
8322 (gnus-info-find-node
8323 (concat "("
8324 (gnus-url-unhex-string
8325 (match-string 1 url))
8326 ")"
8327 (or (gnus-url-unhex-string
8328 (match-string 2 url))
8329 "Top")))
8330 (error "Can't parse %s" url)))
8332 (defun gnus-button-handle-info-url-kde (url)
8333 "Fetch KDE style info URL."
8334 (gnus-info-find-node (gnus-url-unhex-string url)))
8336 ;; (info) will autoload info.el
8337 (declare-function Info-menu "info" (menu-item &optional fork))
8338 (declare-function Info-index-next "info" (num))
8340 (defun gnus-button-handle-info-keystrokes (url)
8341 "Call `info' when pushing the corresponding URL button."
8342 ;; For links like `C-h i d m gnus RET part RET , ,', `C-h i d m CC Mode RET'.
8343 (let (node indx comma)
8344 (if (string-match
8349 url)
8350 (setq node (match-string 2 url)
8351 indx (match-string 3 url))
8352 (error "Can't parse %s" url))
8353 (info)
8354 (Info-directory)
8355 (Info-menu node)
8356 (when (> (length indx) 0)
8359 indx)
8360 (setq comma (match-string 2 indx))
8361 (setq indx (match-string 1 indx))
8362 (Info-index indx)
8363 (when comma
8364 (dotimes (i (with-temp-buffer
8365 (insert comma)
8366 ;; Note: the XEmacs version of `how-many' takes
8367 ;; no optional argument.
8368 (goto-char (point-min))
8369 (how-many ",")))
8370 (Info-index-next 1)))
8371 nil)))
8373 (autoload 'pgg-snarf-keys-region "pgg")
8374 ;; Called after pgg-snarf-keys-region, which autoloads pgg.el.
8375 (declare-function pgg-display-output-buffer "pgg" (start end status))
8377 (defun gnus-button-openpgp (url)
8378 "Retrieve and add an OpenPGP key given URL from an OpenPGP header."
8379 (with-temp-buffer
8380 (mm-url-insert-file-contents-external url)
8381 (pgg-snarf-keys-region (point-min) (point-max))
8382 (pgg-display-output-buffer nil nil nil)))
8384 (defun gnus-button-message-id (message-id)
8385 "Fetch MESSAGE-ID."
8386 (with-current-buffer gnus-summary-buffer
8387 (gnus-summary-refer-article message-id)))
8389 (defun gnus-button-fetch-group (address &rest ignore)
8390 "Fetch GROUP specified by ADDRESS."
8392 address)
8393 ;; Allow to use `gnus-button-fetch-group' in `browse-url-browser-function'
8394 ;; for nntp:// and news://
8395 (setq address (match-string 3 address)))
8396 (if (not (string-match "[:/]" address))
8397 ;; This is just a simple group url.
8398 (gnus-group-read-ephemeral-group address gnus-select-method)
8399 (if (not
8400 (string-match
8402 address))
8403 (error "Can't parse %s" address)
8404 (gnus-group-read-ephemeral-group
8405 (match-string 4 address)
8406 `(nntp ,(match-string 1 address)
8407 (nntp-address ,(match-string 1 address))
8408 (nntp-port-number ,(if (match-end 3)
8409 (match-string 3 address)
8410 "nntp")))
8411 nil nil nil
8412 (and (match-end 6) (list (string-to-number (match-string 6 address))))))))
8414 (defun gnus-url-parse-query-string (query &optional downcase)
8415 (let (retval pairs cur key val)
8416 (setq pairs (split-string query "&"))
8417 (while pairs
8418 (setq cur (car pairs)
8419 pairs (cdr pairs))
8420 (if (not (string-match "=" cur))
8421 nil ; Grace
8422 (setq key (gnus-url-unhex-string (substring cur 0 (match-beginning 0)))
8423 val (gnus-url-unhex-string (substring cur (match-end 0) nil) t))
8424 (if downcase
8425 (setq key (downcase key)))
8426 (setq cur (assoc key retval))
8427 (if cur
8428 (setcdr cur (cons val (cdr cur)))
8429 (setq retval (cons (list key val) retval)))))
8430 retval))
8432 (defun gnus-url-mailto (url)
8433 ;; Send mail to someone
8436 (setq url (substring url (match-beginning 1) nil)))
8437 (let (to args subject func)
8438 (setq args (gnus-url-parse-query-string
8440 (substring url 1)
8442 (concat "to=" (match-string 1 url) "&"
8443 (match-string 2 url))
8444 (concat "to=" url))))
8445 subject (cdr-safe (assoc "subject" args)))
8446 (gnus-msg-mail)
8447 (while args
8448 (setq func (intern-soft (concat "message-goto-" (downcase (caar args)))))
8449 (if (fboundp func)
8450 (funcall func)
8451 (message-position-on-field (caar args)))
8452 (insert (gnus-replace-in-string
8453 (mapconcat 'identity (reverse (cdar args)) ", ")
8455 (setq args (cdr args)))
8456 (if subject
8457 (message-goto-body)
8458 (message-goto-subject))))
8460 (defun gnus-button-embedded-url (address)
8461 "Activate ADDRESS with `browse-url'."
8462 (browse-url (gnus-strip-whitespace address)))
8464 ;;; Next/prev buttons in the article buffer.
8469 (defvar gnus-prev-page-map
8470 (let ((map (make-sparse-keymap)))
8471 (define-key map gnus-mouse-2 'gnus-button-prev-page)
8473 map))
8475 (defvar gnus-next-page-map
8476 (let ((map (make-sparse-keymap)))
8477 (define-key map gnus-mouse-2 'gnus-button-next-page)
8479 map))
8481 (defun gnus-insert-prev-page-button ()
8482 (let ((b (point)) e
8483 (inhibit-read-only t))
8484 (gnus-eval-format
8485 gnus-prev-page-line-format nil
8486 `(keymap ,gnus-prev-page-map
8487 gnus-prev t
8488 gnus-callback gnus-article-button-prev-page
8489 article-type annotation))
8490 (setq e (if (bolp)
8491 ;; Exclude a newline.
8492 (1- (point))
8493 (point)))
8494 (when gnus-article-button-face
8495 (gnus-overlay-put (gnus-make-overlay b e nil t)
8496 'face gnus-article-button-face))
8497 (widget-convert-button
8498 'link b e
8499 :action 'gnus-button-prev-page
8500 :button-keymap gnus-prev-page-map)))
8502 (defun gnus-button-next-page (&optional args more-args)
8503 "Go to the next page."
8504 (interactive)
8505 (let ((win (selected-window)))
8506 (select-window (gnus-get-buffer-window gnus-article-buffer t))
8507 (gnus-article-next-page)
8508 (select-window win)))
8510 (defun gnus-button-prev-page (&optional args more-args)
8511 "Go to the prev page."
8512 (interactive)
8513 (let ((win (selected-window)))
8514 (select-window (gnus-get-buffer-window gnus-article-buffer t))
8515 (gnus-article-prev-page)
8516 (select-window win)))
8518 (defun gnus-insert-next-page-button ()
8519 (let ((b (point)) e
8520 (inhibit-read-only t))
8521 (gnus-eval-format gnus-next-page-line-format nil
8522 `(keymap ,gnus-next-page-map
8523 gnus-next t
8524 gnus-callback gnus-article-button-next-page
8525 article-type annotation))
8526 (setq e (if (bolp)
8527 ;; Exclude a newline.
8528 (1- (point))
8529 (point)))
8530 (when gnus-article-button-face
8531 (gnus-overlay-put (gnus-make-overlay b e nil t)
8532 'face gnus-article-button-face))
8533 (widget-convert-button
8534 'link b e
8535 :action 'gnus-button-next-page
8536 :button-keymap gnus-next-page-map)))
8538 (defun gnus-article-button-next-page (arg)
8539 "Go to the next page."
8540 (interactive "P")
8541 (let ((win (selected-window)))
8542 (select-window (gnus-get-buffer-window gnus-article-buffer t))
8543 (gnus-article-next-page)
8544 (select-window win)))
8546 (defun gnus-article-button-prev-page (arg)
8547 "Go to the prev page."
8548 (interactive "P")
8549 (let ((win (selected-window)))
8550 (select-window (gnus-get-buffer-window gnus-article-buffer t))
8551 (gnus-article-prev-page)
8552 (select-window win)))
8554 (defvar gnus-decode-header-methods
8555 '(mail-decode-encoded-word-region)
8556 "List of methods used to decode headers.
8558 This variable is a list of FUNCTION or (REGEXP . FUNCTION). If item
8559 is FUNCTION, FUNCTION will be applied to all newsgroups. If item is a
8560 \(REGEXP . FUNCTION), FUNCTION will be only apply to the newsgroups
8561 whose names match REGEXP.
8563 For example:
8565 mail-decode-encoded-word-region
8567 ")
8569 (defvar gnus-decode-header-methods-cache nil)
8571 (defun gnus-multi-decode-header (start end)
8572 "Apply the functions from `gnus-encoded-word-methods' that match."
8573 (unless (and gnus-decode-header-methods-cache
8574 (eq gnus-newsgroup-name
8575 (car gnus-decode-header-methods-cache)))
8576 (setq gnus-decode-header-methods-cache (list gnus-newsgroup-name))
8577 (dolist (x gnus-decode-header-methods)
8578 (if (symbolp x)
8579 (nconc gnus-decode-header-methods-cache (list x))
8580 (if (and gnus-newsgroup-name
8581 (string-match (car x) gnus-newsgroup-name))
8582 (nconc gnus-decode-header-methods-cache
8583 (list (cdr x)))))))
8584 (let ((xlist gnus-decode-header-methods-cache))
8585 (pop xlist)
8586 (save-restriction
8587 (narrow-to-region start end)
8588 (while xlist
8589 (funcall (pop xlist) (point-min) (point-max))))))
8591 ;;;
8592 ;;; Treatment top-level handling.
8593 ;;;
8595 (defvar gnus-inhibit-article-treatments nil)
8597 (defun gnus-treat-article (gnus-treat-condition
8598 &optional part-number total-parts gnus-treat-type)
8599 (let ((gnus-treat-length (- (point-max) (point-min)))
8600 (alist gnus-treatment-function-alist)
8601 (article-goto-body-goes-to-point-min-p t)
8602 (treated-type
8603 (or (not gnus-treat-type)
8604 (catch 'found
8605 (let ((list gnus-article-treat-types))
8606 (while list
8607 (when (string-match (pop list) gnus-treat-type)
8608 (throw 'found t)))))))
8609 (highlightp (gnus-visual-p 'article-highlight 'highlight))
8610 val elem)
8611 (gnus-run-hooks 'gnus-part-display-hook)
8612 (dolist (elem alist)
8613 (setq val
8614 (save-excursion
8615 (when (gnus-buffer-live-p gnus-summary-buffer)
8616 (set-buffer gnus-summary-buffer))
8617 (symbol-value (car elem))))
8618 (when (and (or (consp val)
8619 treated-type)
8620 (or (not gnus-inhibit-article-treatments)
8621 (eq gnus-treat-condition 'head))
8622 (gnus-treat-predicate val)
8623 (or (not (get (car elem) 'highlight))
8624 highlightp))
8625 (save-restriction
8626 (funcall (cadr elem)))))))
8628 ;; Dynamic variables.
8629 (defvar part-number)
8630 (defvar total-parts)
8631 (defvar gnus-treat-type)
8632 (defvar gnus-treat-condition)
8633 (defvar gnus-treat-length)
8635 (defun gnus-treat-predicate (val)
8636 (cond
8637 ((null val)
8638 nil)
8639 (gnus-treat-condition
8640 (eq gnus-treat-condition val))
8641 ((and (listp val)
8642 (stringp (car val)))
8643 (apply 'gnus-or (mapcar `(lambda (s)
8644 (string-match s ,(or gnus-newsgroup-name "")))
8645 val)))
8646 ((listp val)
8647 (let ((pred (pop val)))
8648 (cond
8649 ((eq pred 'or)
8650 (apply 'gnus-or (mapcar 'gnus-treat-predicate val)))
8651 ((eq pred 'and)
8652 (apply 'gnus-and (mapcar 'gnus-treat-predicate val)))
8653 ((eq pred 'not)
8654 (not (gnus-treat-predicate (car val))))
8655 ((eq pred 'typep)
8656 (equal (car val) gnus-treat-type))
8657 ((functionp pred)
8658 (funcall pred))
8659 (t
8660 (error "%S is not a valid predicate" pred)))))
8661 ((eq val t)
8662 t)
8663 ((eq val 'head)
8664 nil)
8665 ((eq val 'first)
8666 (eq part-number 1))
8667 ((eq val 'last)
8668 (eq part-number total-parts))
8669 ((numberp val)
8670 (< gnus-treat-length val))
8671 (t
8672 (error "%S is not a valid value" val))))
8674 (defun gnus-article-encrypt-body (protocol &optional n)
8675 "Encrypt the article body."
8676 (interactive
8677 (list
8678 (or gnus-article-encrypt-protocol
8679 (gnus-completing-read "Encrypt protocol"
8680 (mapcar 'car gnus-article-encrypt-protocol-alist)
8681 t))
8682 current-prefix-arg))
8683 ;; User might hit `K E' instead of `K e', so prompt once.
8684 (when (and gnus-article-encrypt-protocol
8685 gnus-novice-user)
8686 (unless (gnus-y-or-n-p "Really encrypt article(s)? ")
8687 (error "Encrypt aborted")))
8688 (let ((func (cdr (assoc protocol gnus-article-encrypt-protocol-alist))))
8689 (unless func
8690 (error "Can't find the encrypt protocol %s" protocol))
8691 (if (member gnus-newsgroup-name '("nndraft:delayed"
8692 "nndraft:drafts"
8693 "nndraft:queue"))
8694 (error "Can't encrypt the article in group %s"
8695 gnus-newsgroup-name))
8696 (gnus-summary-iterate n
8697 (with-current-buffer gnus-summary-buffer
8698 (let ((mail-parse-charset gnus-newsgroup-charset)
8699 (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets)
8700 (summary-buffer gnus-summary-buffer)
8701 references point)
8702 (gnus-set-global-variables)
8703 (when (gnus-group-read-only-p)
8704 (error "The current newsgroup does not support article encrypt"))
8705 (gnus-summary-show-article t)
8706 (setq references
8707 (or (mail-header-references gnus-current-headers) ""))
8708 (set-buffer gnus-article-buffer)
8709 (let* ((inhibit-read-only t)
8710 (headers
8711 (mapcar (lambda (field)
8712 (and (save-restriction
8713 (message-narrow-to-head)
8714 (goto-char (point-min))
8715 (search-forward field nil t))
8716 (prog2
8717 (message-narrow-to-field)
8718 (buffer-string)
8719 (delete-region (point-min) (point-max))
8720 (widen))))
8721 '("Content-Type:" "Content-Transfer-Encoding:"
8722 "Content-Disposition:"))))
8723 (message-narrow-to-head)
8724 (message-remove-header "MIME-Version")
8725 (goto-char (point-max))
8726 (setq point (point))
8727 (insert (apply 'concat headers))
8728 (widen)
8729 (narrow-to-region point (point-max))
8730 (let ((message-options message-options))
8731 (message-options-set 'message-sender user-mail-address)
8732 (message-options-set 'message-recipients user-mail-address)
8733 (message-options-set 'message-sign-encrypt 'not)
8734 (funcall func))
8735 (goto-char (point-min))
8737 (widen)
8738 (gnus-summary-edit-article-done
8739 references nil summary-buffer t))
8740 (when gnus-keep-backlog
8741 (gnus-backlog-remove-article
8742 (car gnus-article-current) (cdr gnus-article-current)))
8743 (gnus-flush-original-article-buffer)
8744 (when gnus-use-cache
8745 (gnus-cache-update-article
8746 (car gnus-article-current) (cdr gnus-article-current))))))))
8749 "The following specs can be used:
8750 %t The security MIME type
8751 %i Additional info
8752 %d Details
8753 %D Details if button is pressed")
8756 "The following specs can be used:
8757 %t The security MIME type
8758 %i Additional info
8759 %d Details
8760 %D Details if button is pressed")
8762 (defvar gnus-mime-security-button-line-format-alist
8763 '((?t gnus-tmp-type ?s)
8764 (?i gnus-tmp-info ?s)
8765 (?d gnus-tmp-details ?s)
8766 (?D gnus-tmp-pressed-details ?s)))
8768 (defvar gnus-mime-security-button-commands
8770 (undefined "v")
8771 (undefined "t")
8772 (undefined "C")
8773 (gnus-mime-security-save-part "o" "Save...")
8774 (undefined "\C-o")
8775 (undefined "r")
8776 (undefined "d")
8777 (undefined "c")
8778 (undefined "i")
8779 (undefined "E")
8780 (undefined "e")
8781 (undefined "p")
8782 (gnus-mime-security-pipe-part "|" "Pipe To Command...")
8783 (undefined ".")))
8785 (defvar gnus-mime-security-button-map
8786 (let ((map (make-sparse-keymap)))
8787 (define-key map gnus-mouse-2 'gnus-article-push-button)
8788 (define-key map gnus-down-mouse-3 'gnus-mime-security-button-menu)
8789 (dolist (c gnus-mime-security-button-commands)
8790 (define-key map (cadr c) (car c)))
8791 map))
8793 (easy-menu-define
8794 gnus-mime-security-button-menu gnus-mime-security-button-map
8795 "Security button menu."
8796 `("Security Part"
8797 ,@(delq nil
8798 (mapcar (lambda (c)
8799 (unless (eq (car c) 'undefined)
8800 (vector (caddr c) (car c) :active t)))
8801 gnus-mime-security-button-commands))))
8803 (defun gnus-mime-security-button-menu (event prefix)
8804 "Construct a context-sensitive menu of security commands."
8806 (save-window-excursion
8807 (let ((pos (event-start event)))
8808 (select-window (posn-window pos))
8809 (goto-char (posn-point pos))
8810 (gnus-article-check-buffer)
8811 (popup-menu gnus-mime-security-button-menu nil prefix))))
8813 (defvar gnus-mime-security-details-buffer nil)
8815 (defvar gnus-mime-security-button-pressed nil)
8817 (defvar gnus-mime-security-show-details-inline t
8818 "If non-nil, show details in the article buffer.")
8820 (defun gnus-mime-security-verify-or-decrypt (handle)
8821 (mm-remove-parts (cdr handle))
8822 (let ((region (mm-handle-multipart-ctl-parameter handle 'gnus-region))
8823 point (inhibit-read-only t))
8824 (if region
8825 (goto-char (car region)))
8826 (setq point (point))
8827 (with-current-buffer (mm-handle-multipart-original-buffer handle)
8828 (let* ((mm-verify-option 'known)
8829 (mm-decrypt-option 'known)
8830 (nparts (mm-possibly-verify-or-decrypt (cdr handle) handle)))
8831 (unless (eq nparts (cdr handle))
8832 (mm-destroy-parts (cdr handle))
8833 (setcdr handle nparts))))
8834 (gnus-mime-display-security handle)
8835 (when region
8836 (delete-region (point) (cdr region))
8837 (set-marker (car region) nil)
8838 (set-marker (cdr region) nil))
8839 (goto-char point)))
8841 (defun gnus-mime-security-show-details (handle)
8842 (let ((details (mm-handle-multipart-ctl-parameter handle 'gnus-details)))
8843 (if (not details)
8844 (gnus-message 5 "No details.")
8845 (if gnus-mime-security-show-details-inline
8846 (let ((gnus-mime-security-button-pressed
8847 (not (get-text-property (point) 'gnus-mime-details)))
8848 (gnus-mime-security-button-line-format
8849 (get-text-property (point) 'gnus-line-format))
8850 (inhibit-read-only t))
8851 (forward-char -1)
8852 (while (eq (get-text-property (point) 'gnus-line-format)
8853 gnus-mime-security-button-line-format)
8854 (forward-char -1))
8855 (forward-char)
8856 (save-restriction
8857 (narrow-to-region (point) (point))
8858 (gnus-insert-mime-security-button handle))
8859 (delete-region (point)
8860 (or (text-property-not-all
8861 (point) (point-max)
8862 'gnus-line-format
8863 gnus-mime-security-button-line-format)
8864 (point-max))))
8865 ;; Not inlined.
8866 (if (gnus-buffer-live-p gnus-mime-security-details-buffer)
8867 (with-current-buffer gnus-mime-security-details-buffer
8868 (erase-buffer)
8869 t)
8870 (setq gnus-mime-security-details-buffer
8871 (gnus-get-buffer-create "*MIME Security Details*")))
8872 (with-current-buffer gnus-mime-security-details-buffer
8873 (insert details)
8874 (goto-char (point-min)))
8875 (pop-to-buffer gnus-mime-security-details-buffer)))))
8877 (defun gnus-mime-security-press-button (handle)
8878 (save-excursion
8879 (if (mm-handle-multipart-ctl-parameter handle 'gnus-info)
8880 (gnus-mime-security-show-details handle)
8881 (gnus-mime-security-verify-or-decrypt handle))))
8883 (defun gnus-insert-mime-security-button (handle &optional displayed)
8884 (let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol))
8885 (gnus-tmp-type
8886 (concat
8887 (or (nth 2 (assoc protocol mm-verify-function-alist))
8888 (nth 2 (assoc protocol mm-decrypt-function-alist))
8889 "Unknown")
8890 (if (equal (car handle) "multipart/signed")
8891 " Signed" " Encrypted")
8892 " Part"))
8893 (gnus-tmp-info
8894 (or (mm-handle-multipart-ctl-parameter handle 'gnus-info)
8895 "Undecided"))
8896 (gnus-tmp-details
8897 (mm-handle-multipart-ctl-parameter handle 'gnus-details))
8898 gnus-tmp-pressed-details
8899 b e)
8900 (setq gnus-tmp-details
8901 (if gnus-tmp-details
8903 ""))
8904 (setq gnus-tmp-pressed-details
8905 (if gnus-mime-security-button-pressed gnus-tmp-details ""))
8906 (unless (bolp)
8908 (setq b (point))
8909 (gnus-eval-format
8910 gnus-mime-security-button-line-format
8911 gnus-mime-security-button-line-format-alist
8912 `(keymap ,gnus-mime-security-button-map
8913 gnus-callback gnus-mime-security-press-button
8914 gnus-line-format ,gnus-mime-security-button-line-format
8915 gnus-mime-details ,gnus-mime-security-button-pressed
8916 article-type annotation
8917 gnus-data ,handle))
8918 (setq e (if (bolp)
8919 ;; Exclude a newline.
8920 (1- (point))
8921 (point)))
8922 (when gnus-article-button-face
8923 (gnus-overlay-put (gnus-make-overlay b e nil t)
8924 'face gnus-article-button-face))
8925 (widget-convert-button
8926 'link b e
8927 :mime-handle handle
8928 :action 'gnus-widget-press-button
8929 :button-keymap gnus-mime-security-button-map
8930 :help-echo
8931 (lambda (widget)
8932 ;; Needed to properly clear the message due to a bug in
8933 ;; wid-edit (XEmacs only).
8934 (when (boundp 'help-echo-owns-message)
8935 (setq help-echo-owns-message t))
8936 (format
8937 "%S: show detail; %S: more options"
8938 (aref gnus-mouse-2 0)
8939 (aref gnus-down-mouse-3 0))))))
8941 (defun gnus-mime-display-security (handle)
8942 (save-restriction
8943 (narrow-to-region (point) (point))
8944 (unless (gnus-unbuttonized-mime-type-p (car handle))
8945 (gnus-insert-mime-security-button handle))
8946 (gnus-mime-display-part (cadr handle))
8947 (unless (bolp)
8949 (unless (gnus-unbuttonized-mime-type-p (car handle))
8950 (let ((gnus-mime-security-button-line-format
8951 gnus-mime-security-button-end-line-format))
8952 (gnus-insert-mime-security-button handle)))
8953 (mm-set-handle-multipart-parameter
8954 handle 'gnus-region (cons (point-min-marker) (point-max-marker)))
8955 (goto-char (point-max))))
8957 (defun gnus-mime-security-run-function (function)
8958 "Run FUNCTION with the security part under point."
8959 (gnus-article-check-buffer)
8960 (let ((data (get-text-property (point) 'gnus-data))
8961 buffer handle)
8962 (when (and (stringp (car-safe data))
8963 (setq buffer (mm-handle-multipart-original-buffer data))
8964 (setq handle (cadr data)))
8965 (if (bufferp (mm-handle-buffer handle))
8966 (progn
8967 (setq handle (cons buffer (copy-sequence (cdr handle))))
8968 (mm-handle-set-undisplayer handle nil))
8969 (setq handle (mm-make-handle
8970 buffer
8971 (mm-handle-multipart-ctl-parameter handle 'protocol)
8972 nil nil nil nil nil nil)))
8973 (funcall function handle))))
8975 (defun gnus-mime-security-save-part ()
8976 "Save the security part under point."
8977 (interactive)
8978 (gnus-mime-security-run-function 'mm-save-part))
8980 (defun gnus-mime-security-pipe-part ()
8981 "Pipe the security part under point to a process."
8982 (interactive)
8983 (gnus-mime-security-run-function 'mm-pipe-part))
8985 (gnus-ems-redefine)
8987 (provide 'gnus-art)
8989 (run-hooks 'gnus-art-load-hook)
8991 ;;; gnus-art.el ends here