/[emacs]/emacs/lisp/gnus/gnus-art.el
ViewVC logotype

Diff of /emacs/lisp/gnus/gnus-art.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.41.2.3 by miles, Thu Apr 1 04:29:04 2004 UTC revision 1.41.2.4 by miles, Thu Sep 16 00:12:15 2004 UTC
# Line 1  Line 1 
1  ;;; gnus-art.el --- article mode commands for Gnus  ;;; gnus-art.el --- article mode commands for Gnus
2    ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004
3  ;; Copyright (C) 1996, 97, 98, 1999, 2000, 01, 02, 2004  ;;        Free Software Foundation, Inc.
 ;;   Free Software Foundation, Inc.  
4    
5  ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>  ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
6  ;; Keywords: news  ;; Keywords: news
# Line 27  Line 26 
26    
27  ;;; Code:  ;;; Code:
28    
29  (eval-when-compile (require 'cl))  (eval-when-compile
30      (require 'cl)
31      (defvar tool-bar-map))
32    
33  (require 'gnus)  (require 'gnus)
34  (require 'gnus-sum)  (require 'gnus-sum)
35  (require 'gnus-spec)  (require 'gnus-spec)
36  (require 'gnus-int)  (require 'gnus-int)
37    (require 'gnus-win)
38  (require 'mm-bodies)  (require 'mm-bodies)
39  (require 'mail-parse)  (require 'mail-parse)
40  (require 'mm-decode)  (require 'mm-decode)
41  (require 'mm-view)  (require 'mm-view)
42  (require 'wid-edit)  (require 'wid-edit)
43  (require 'mm-uu)  (require 'mm-uu)
44    (require 'message)
45    
46    (autoload 'gnus-msg-mail "gnus-msg" nil t)
47    (autoload 'gnus-button-mailto "gnus-msg")
48    (autoload 'gnus-button-reply "gnus-msg" nil t)
49    
50  (defgroup gnus-article nil  (defgroup gnus-article nil
51    "Article display."    "Article display."
52    :link '(custom-manual "(gnus)The Article Buffer")    :link '(custom-manual "(gnus)Article Buffer")
53    :group 'gnus)    :group 'gnus)
54    
55  (defgroup gnus-article-treat nil  (defgroup gnus-article-treat nil
# Line 102  Line 109 
109    :group 'gnus-article)    :group 'gnus-article)
110    
111  (defcustom gnus-ignored-headers  (defcustom gnus-ignored-headers
112    '("^Path:" "^Expires:" "^Date-Received:" "^References:" "^Xref:" "^Lines:"    (mapcar
113      "^Relay-Version:" "^Message-ID:" "^Approved:" "^Sender:" "^Received:"     (lambda (header)
114      "^X-UIDL:" "^MIME-Version:" "^Return-Path:" "^In-Reply-To:"       (concat "^" header ":"))
115      "^Content-Type:" "^Content-Transfer-Encoding:" "^X-WebTV-Signature:"     '("Path" "Expires" "Date-Received" "References" "Xref" "Lines"
116      "^X-MimeOLE:" "^X-MSMail-Priority:" "^X-Priority:" "^X-Loop:"       "Relay-Version" "Message-ID" "Approved" "Sender" "Received"
117      "^X-Authentication-Warning:" "^X-MIME-Autoconverted:" "^X-Face:"       "X-UIDL" "MIME-Version" "Return-Path" "In-Reply-To"
118      "^X-Attribution:" "^X-Originating-IP:" "^Delivered-To:"       "Content-Type" "Content-Transfer-Encoding" "X-WebTV-Signature"
119      "^NNTP-[-A-Za-z]+:" "^Distribution:" "^X-no-archive:" "^X-Trace:"       "X-MimeOLE" "X-MSMail-Priority" "X-Priority" "X-Loop"
120      "^X-Complaints-To:" "^X-NNTP-Posting-Host:" "^X-Orig.*:"       "X-Authentication-Warning" "X-MIME-Autoconverted" "X-Face"
121      "^Abuse-Reports-To:" "^Cache-Post-Path:" "^X-Article-Creation-Date:"       "X-Attribution" "X-Originating-IP" "Delivered-To"
122      "^X-Poster:" "^X-Mail2News-Path:" "^X-Server-Date:" "^X-Cache:"       "NNTP-[-A-Za-z]+" "Distribution" "X-no-archive" "X-Trace"
123      "^Originator:" "^X-Problems-To:" "^X-Auth-User:" "^X-Post-Time:"       "X-Complaints-To" "X-NNTP-Posting-Host" "X-Orig.*"
124      "^X-Admin:" "^X-UID:" "^Resent-[-A-Za-z]+:" "^X-Mailing-List:"       "Abuse-Reports-To" "Cache-Post-Path" "X-Article-Creation-Date"
125      "^Precedence:" "^Original-[-A-Za-z]+:" "^X-filename:" "^X-Orcpt:"       "X-Poster" "X-Mail2News-Path" "X-Server-Date" "X-Cache"
126      "^Old-Received:" "^X-Pgp" "^X-Auth:" "^X-From-Line:"       "Originator" "X-Problems-To" "X-Auth-User" "X-Post-Time"
127      "^X-Gnus-Article-Number:" "^X-Majordomo:" "^X-Url:" "^X-Sender:"       "X-Admin" "X-UID" "Resent-[-A-Za-z]+" "X-Mailing-List"
128      "^MBOX-Line" "^Priority:" "^X-Pgp" "^X400-[-A-Za-z]+:"       "Precedence" "Original-[-A-Za-z]+" "X-filename" "X-Orcpt"
129      "^Status:" "^X-Gnus-Mail-Source:" "^Cancel-Lock:"       "Old-Received" "X-Pgp" "X-Auth" "X-From-Line"
130      "^X-FTN" "^X-EXP32-SerialNo:" "^Encoding:" "^Importance:"       "X-Gnus-Article-Number" "X-Majordomo" "X-Url" "X-Sender"
131      "^Autoforwarded:" "^Original-Encoded-Information-Types:" "^X-Ya-Pop3:"       "MBOX-Line" "Priority" "X400-[-A-Za-z]+"
132      "^X-Face-Version:" "^X-Vms-To:" "^X-ML-NAME:" "^X-ML-COUNT:"       "Status" "X-Gnus-Mail-Source" "Cancel-Lock"
133      "^Mailing-List:" "^X-finfo:" "^X-md5sum:" "^X-md5sum-Origin:"       "X-FTN" "X-EXP32-SerialNo" "Encoding" "Importance"
134      "^X-Sun-Charset:" "^X-Accept-Language:" "^X-Envelope-Sender:"       "Autoforwarded" "Original-Encoded-Information-Types" "X-Ya-Pop3"
135      "^List-[A-Za-z]+:" "^X-Listprocessor-Version:"       "X-Face-Version" "X-Vms-To" "X-ML-NAME" "X-ML-COUNT"
136      "^X-Received:" "^X-Distribute:" "^X-Sequence:" "^X-Juno-Line-Breaks:"       "Mailing-List" "X-finfo" "X-md5sum" "X-md5sum-Origin"
137      "^X-Notes-Item:" "^X-MS-TNEF-Correlator:" "^x-uunet-gateway:"       "X-Sun-Charset" "X-Accept-Language" "X-Envelope-Sender"
138      "^X-Received:" "^Content-length:" "X-precedence:")       "List-[A-Za-z]+" "X-Listprocessor-Version"
139         "X-Received" "X-Distribute" "X-Sequence" "X-Juno-Line-Breaks"
140         "X-Notes-Item" "X-MS-TNEF-Correlator" "x-uunet-gateway"
141         "X-Received" "Content-length" "X-precedence"
142         "X-Authenticated-User" "X-Comment" "X-Report" "X-Abuse-Info"
143         "X-HTTP-Proxy" "X-Mydeja-Info" "X-Copyright" "X-No-Markup"
144         "X-Abuse-Info" "X-From_" "X-Accept-Language" "Errors-To"
145         "X-BeenThere" "X-Mailman-Version" "List-Help" "List-Post"
146         "List-Subscribe" "List-Id" "List-Unsubscribe" "List-Archive"
147         "X-Content-length" "X-Posting-Agent" "Original-Received"
148         "X-Request-PGP" "X-Fingerprint" "X-WRIEnvto" "X-WRIEnvfrom"
149         "X-Virus-Scanned" "X-Delivery-Agent" "Posted-Date" "X-Gateway"
150         "X-Local-Origin" "X-Local-Destination" "X-UserInfo1"
151         "X-Received-Date" "X-Hashcash" "Face" "X-DMCA-Notifications"
152         "X-Abuse-and-DMCA-Info" "X-Postfilter" "X-Gpg-.*" "X-Disclaimer"))
153    "*All headers that start with this regexp will be hidden.    "*All headers that start with this regexp will be hidden.
154  This variable can also be a list of regexps of headers to be ignored.  This variable can also be a list of regexps of headers to be ignored.
155  If `gnus-visible-headers' is non-nil, this variable will be ignored."  If `gnus-visible-headers' is non-nil, this variable will be ignored."
# Line 138  If `gnus-visible-headers' is non-nil, th Line 159  If `gnus-visible-headers' is non-nil, th
159    :group 'gnus-article-hiding)    :group 'gnus-article-hiding)
160    
161  (defcustom gnus-visible-headers  (defcustom gnus-visible-headers
162    "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^[BGF]?Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|^X-Sent:"    "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^[BGF]?Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Mail-Followup-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|^X-Sent:"
163    "*All headers that do not match this regexp will be hidden.    "*All headers that do not match this regexp will be hidden.
164  This variable can also be a list of regexp of headers to remain visible.  This variable can also be a list of regexp of headers to remain visible.
165  If this variable is non-nil, `gnus-ignored-headers' will be ignored."  If this variable is non-nil, `gnus-ignored-headers' will be ignored."
# Line 162  this list." Line 183  this list."
183    
184  (defcustom gnus-boring-article-headers '(empty followup-to reply-to)  (defcustom gnus-boring-article-headers '(empty followup-to reply-to)
185    "Headers that are only to be displayed if they have interesting data.    "Headers that are only to be displayed if they have interesting data.
186  Possible values in this list are `empty', `newsgroups', `followup-to',  Possible values in this list are:
187  `reply-to', `date', `long-to', and `many-to'."  
188      'empty       Headers with no content.
189      'newsgroups  Newsgroup identical to Gnus group.
190      'to-address  To identical to To-address.
191      'to-list     To identical to To-list.
192      'cc-list     CC identical to To-list.
193      'followup-to Followup-to identical to Newsgroups.
194      'reply-to    Reply-to identical to From.
195      'date        Date less than four days old.
196      'long-to     To and/or Cc longer than 1024 characters.
197      'many-to     Multiple To and/or Cc."
198    :type '(set (const :tag "Headers with no content." empty)    :type '(set (const :tag "Headers with no content." empty)
199                (const :tag "Newsgroups with only one group." newsgroups)                (const :tag "Newsgroups identical to Gnus group." newsgroups)
200                (const :tag "Followup-to identical to newsgroups." followup-to)                (const :tag "To identical to To-address." to-address)
201                (const :tag "Reply-to identical to from." reply-to)                (const :tag "To identical to To-list." to-list)
202                  (const :tag "CC identical to To-list." cc-list)
203                  (const :tag "Followup-to identical to Newsgroups." followup-to)
204                  (const :tag "Reply-to identical to From." reply-to)
205                (const :tag "Date less than four days old." date)                (const :tag "Date less than four days old." date)
206                (const :tag "Very long To and/or Cc header." long-to)                (const :tag "To and/or Cc longer than 1024 characters." long-to)
207                (const :tag "Multiple To and/or Cc headers." many-to))                (const :tag "Multiple To and/or Cc headers." many-to))
208    :group 'gnus-article-hiding)    :group 'gnus-article-hiding)
209    
210    (defcustom gnus-article-skip-boring nil
211      "Skip over text that is not worth reading.
212    By default, if you set this t, then Gnus will display citations and
213    signatures, but will never scroll down to show you a page consisting
214    only of boring text.  Boring text is controlled by
215    `gnus-article-boring-faces'."
216      :type 'boolean
217      :group 'gnus-article-hiding)
218    
219  (defcustom gnus-signature-separator '("^-- $" "^-- *$")  (defcustom gnus-signature-separator '("^-- $" "^-- *$")
220    "Regexp matching signature separator.    "Regexp matching signature separator.
221  This can also be a list of regexps.  In that case, it will be checked  This can also be a list of regexps.  In that case, it will be checked
# Line 200  regexp.  If it matches, the text in ques Line 243  regexp.  If it matches, the text in ques
243    :type 'sexp    :type 'sexp
244    :group 'gnus-article-hiding)    :group 'gnus-article-hiding)
245    
246  ;; Fixme: This isn't the right thing for mixed graphical and and  ;; Fixme: This isn't the right thing for mixed graphical and non-graphical
247  ;; non-graphical frames in a session.  ;; frames in a session.
 ;; gnus-xmas.el overrides this for XEmacs.  
248  (defcustom gnus-article-x-face-command  (defcustom gnus-article-x-face-command
249    (if (and (fboundp 'image-type-available-p)    (if (featurep 'xemacs)
250             (image-type-available-p 'xbm))        (if (or (gnus-image-type-available-p 'xface)
251        'gnus-article-display-xface                (gnus-image-type-available-p 'pbm))
252      (if (or (and (boundp 'gnus-article-compface-xbm)            'gnus-display-x-face-in-from
253                   gnus-article-compface-xbm)          "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | ee -")
254              (eq 0 (string-match "#define"      (if (gnus-image-type-available-p 'pbm)
255                                  (shell-command-to-string "uncompface -X"))))          'gnus-display-x-face-in-from
         "{ echo '/* Width=48, Height=48 */'; uncompface; } | display -"  
256        "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | \        "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | \
257  display -"))  display -"))
258    "*String or function to be executed to display an X-Face header.    "*String or function to be executed to display an X-Face header.
259  If it is a string, the command will be executed in a sub-shell  If it is a string, the command will be executed in a sub-shell
260  asynchronously.  The compressed face will be piped to this command."  asynchronously.  The compressed face will be piped to this command."
261    :type '(choice string    :type `(choice string
262                   (function-item gnus-article-display-xface)                   (function-item gnus-display-x-face-in-from)
263                   function)                   function)
264    :version "21.1"    :version "21.1"
265      :group 'gnus-picon
266    :group 'gnus-article-washing)    :group 'gnus-article-washing)
267    
268  (defcustom gnus-article-x-face-too-ugly nil  (defcustom gnus-article-x-face-too-ugly nil
# Line 231  asynchronously.         The compressed face wil Line 273  asynchronously.         The compressed face wil
273  (defcustom gnus-article-banner-alist nil  (defcustom gnus-article-banner-alist nil
274    "Banner alist for stripping.    "Banner alist for stripping.
275  For example,  For example,
276       ((egroups . \"^[ \\t\\n]*-------------------+\\\\( eGroups Sponsor -+\\\\)?....\\n\\\\(.+\\n\\\\)+\"))"       ((egroups . \"^[ \\t\\n]*-------------------+\\\\( \\\\(e\\\\|Yahoo! \\\\)Groups Sponsor -+\\\\)?....\\n\\\\(.+\\n\\\\)+\"))"
277    :version "21.1"    :version "21.1"
278    :type '(repeat (cons symbol regexp))    :type '(repeat (cons symbol regexp))
279    :group 'gnus-article-washing)    :group 'gnus-article-washing)
280    
281    (gnus-define-group-parameter
282     banner
283     :variable-document
284     "Alist of regexps (to match group names) and banner."
285     :variable-group gnus-article-washing
286     :parameter-type
287     '(choice :tag "Banner"
288              :value nil
289              (const :tag "Remove signature" signature)
290              (symbol :tag "Item in `gnus-article-banner-alist'" none)
291              regexp
292              (const :tag "None" nil))
293     :parameter-document
294     "If non-nil, specify how to remove `banners' from articles.
295    
296    Symbol `signature' means to remove signatures delimited by
297    `gnus-signature-separator'.  Any other symbol is used to look up a
298    regular expression to match the banner in `gnus-article-banner-alist'.
299    A string is used as a regular expression to match the banner
300    directly.")
301    
302    (defcustom gnus-article-address-banner-alist nil
303      "Alist of mail addresses and banners.
304    Each element has the form (ADDRESS . BANNER), where ADDRESS is a regexp
305    to match a mail address in the From: header, BANNER is one of a symbol
306    `signature', an item in `gnus-article-banner-alist', a regexp and nil.
307    If ADDRESS matches author's mail address, it will remove things like
308    advertisements.  For example:
309    
310    \((\"@yoo-hoo\\\\.co\\\\.jp\\\\'\" . \"\\n_+\\nDo You Yoo-hoo!\\\\?\\n.*\\n.*\\n\"))
311    "
312      :type '(repeat
313              (cons
314               (regexp :tag "Address")
315               (choice :tag "Banner" :value nil
316                       (const :tag "Remove signature" signature)
317                       (symbol :tag "Item in `gnus-article-banner-alist'" none)
318                       regexp
319                       (const :tag "None" nil))))
320      :group 'gnus-article-washing)
321    
322  (defcustom gnus-emphasis-alist  (defcustom gnus-emphasis-alist
323    (let ((format    (let ((format
324           "\\(\\s-\\|^\\|[-\"]\\|\\s(\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\s-\\|[-,;:\"]\\s-\\|[?!.]+\\s-\\|\\s)\\)")           "\\(\\s-\\|^\\|\\=\\|[-\"]\\|\\s(\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\([-,.;:!?\"]\\|\\s)\\)+\\s-\\|[?!.]\\s-\\|\\s)\\|\\s-\\)")
325          (types          (types
326           '(("_" "_" underline)           '(("\\*" "\\*" bold)
327               ("_" "_" underline)
328             ("/" "/" italic)             ("/" "/" italic)
            ("\\*" "\\*" bold)  
329             ("_/" "/_" underline-italic)             ("_/" "/_" underline-italic)
330             ("_\\*" "\\*_" underline-bold)             ("_\\*" "\\*_" underline-bold)
331             ("\\*/" "/\\*" bold-italic)             ("\\*/" "/\\*" bold-italic)
332             ("_\\*/" "/\\*_" underline-bold-italic))))             ("_\\*/" "/\\*_" underline-bold-italic))))
333      `(("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)"      `(,@(mapcar
        2 3 gnus-emphasis-underline)  
       ,@(mapcar  
334           (lambda (spec)           (lambda (spec)
335             (list             (list
336              (format format (car spec) (cadr spec))              (format format (car spec) (cadr spec))
337              2 3 (intern (format "gnus-emphasis-%s" (nth 2 spec)))))              2 3 (intern (format "gnus-emphasis-%s" (nth 2 spec)))))
338           types)))           types)
339            ("\\(\\s-\\|^\\)\\(-\\(\\(\\w\\|-[^-]\\)+\\)-\\)\\(\\s-\\|[?!.,;]\\)"
340             2 3 gnus-emphasis-strikethru)
341            ("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)"
342             2 3 gnus-emphasis-underline)))
343    "*Alist that says how to fontify certain phrases.    "*Alist that says how to fontify certain phrases.
344  Each item looks like this:  Each item looks like this:
345    
# Line 281  and the latter avoids underlining any wh Line 366  and the latter avoids underlining any wh
366    :group 'gnus-article-emphasis    :group 'gnus-article-emphasis
367    :type 'regexp)    :type 'regexp)
368    
369  (defface gnus-emphasis-bold '((t (:weight bold)))  (defface gnus-emphasis-bold '((t (:bold t)))
370    "Face used for displaying strong emphasized text (*word*)."    "Face used for displaying strong emphasized text (*word*)."
371    :group 'gnus-article-emphasis)    :group 'gnus-article-emphasis)
372    
373  (defface gnus-emphasis-italic '((t (:slant italic)))  (defface gnus-emphasis-italic '((t (:italic t)))
374    "Face used for displaying italic emphasized text (/word/)."    "Face used for displaying italic emphasized text (/word/)."
375    :group 'gnus-article-emphasis)    :group 'gnus-article-emphasis)
376    
# Line 293  and the latter avoids underlining any wh Line 378  and the latter avoids underlining any wh
378    "Face used for displaying underlined emphasized text (_word_)."    "Face used for displaying underlined emphasized text (_word_)."
379    :group 'gnus-article-emphasis)    :group 'gnus-article-emphasis)
380    
381  (defface gnus-emphasis-underline-bold '((t (:weight bold :underline t)))  (defface gnus-emphasis-underline-bold '((t (:bold t :underline t)))
382    "Face used for displaying underlined bold emphasized text (_*word*_)."    "Face used for displaying underlined bold emphasized text (_*word*_)."
383    :group 'gnus-article-emphasis)    :group 'gnus-article-emphasis)
384    
385  (defface gnus-emphasis-underline-italic '((t (:slant italic :underline t)))  (defface gnus-emphasis-underline-italic '((t (:italic t :underline t)))
386    "Face used for displaying underlined italic emphasized text (_/word/_)."    "Face used for displaying underlined italic emphasized text (_/word/_)."
387    :group 'gnus-article-emphasis)    :group 'gnus-article-emphasis)
388    
389  (defface gnus-emphasis-bold-italic '((t (:weight bold :slant italic)))  (defface gnus-emphasis-bold-italic '((t (:bold t :italic t)))
390    "Face used for displaying bold italic emphasized text (/*word*/)."    "Face used for displaying bold italic emphasized text (/*word*/)."
391    :group 'gnus-article-emphasis)    :group 'gnus-article-emphasis)
392    
393  (defface gnus-emphasis-underline-bold-italic  (defface gnus-emphasis-underline-bold-italic
394    '((t (:weight bold :slant italic :underline t)))    '((t (:bold t :italic t :underline t)))
395    "Face used for displaying underlined bold italic emphasized text.    "Face used for displaying underlined bold italic emphasized text.
396  Example: (_/*word*/_)."  Example: (_/*word*/_)."
397    :group 'gnus-article-emphasis)    :group 'gnus-article-emphasis)
398    
399    (defface gnus-emphasis-strikethru (if (featurep 'xemacs)
400                                          '((t (:strikethru t)))
401                                        '((t (:strike-through t))))
402      "Face used for displaying strike-through text (-word-)."
403      :group 'gnus-article-emphasis)
404    
405  (defface gnus-emphasis-highlight-words  (defface gnus-emphasis-highlight-words
406    '((t (:background "black" :foreground "yellow")))    '((t (:background "black" :foreground "yellow")))
407    "Face used for displaying highlighted words."    "Face used for displaying highlighted words."
# Line 367  Gnus provides the following functions: Line 458  Gnus provides the following functions:
458  * gnus-summary-save-in-mail (Unix mail format)  * gnus-summary-save-in-mail (Unix mail format)
459  * gnus-summary-save-in-folder (MH folder)  * gnus-summary-save-in-folder (MH folder)
460  * gnus-summary-save-in-file (article format)  * gnus-summary-save-in-file (article format)
461    * gnus-summary-save-body-in-file (article body)
462  * gnus-summary-save-in-vm (use VM's folder format)  * gnus-summary-save-in-vm (use VM's folder format)
463  * gnus-summary-write-to-file (article format -- overwrite)."  * gnus-summary-write-to-file (article format -- overwrite)."
464    :group 'gnus-article-saving    :group 'gnus-article-saving
# Line 374  Gnus provides the following functions: Line 466  Gnus provides the following functions:
466                  (function-item gnus-summary-save-in-mail)                  (function-item gnus-summary-save-in-mail)
467                  (function-item gnus-summary-save-in-folder)                  (function-item gnus-summary-save-in-folder)
468                  (function-item gnus-summary-save-in-file)                  (function-item gnus-summary-save-in-file)
469                    (function-item gnus-summary-save-body-in-file)
470                  (function-item gnus-summary-save-in-vm)                  (function-item gnus-summary-save-in-vm)
471                  (function-item gnus-summary-write-to-file)))                  (function-item gnus-summary-write-to-file)))
472    
# Line 452  The following additional specs are avail Line 545  The following additional specs are avail
545    :type 'hook    :type 'hook
546    :group 'gnus-article-various)    :group 'gnus-article-various)
547    
548    (when (featurep 'xemacs)
549      ;; Extracted from gnus-xmas-define in order to preserve user settings
550      (when (fboundp 'turn-off-scroll-in-place)
551        (add-hook 'gnus-article-mode-hook 'turn-off-scroll-in-place))
552      ;; Extracted from gnus-xmas-redefine in order to preserve user settings
553      (add-hook 'gnus-article-mode-hook 'gnus-xmas-article-menu-add))
554    
555  (defcustom gnus-article-menu-hook nil  (defcustom gnus-article-menu-hook nil
556    "*Hook run after the creation of the article mode menu."    "*Hook run after the creation of the article mode menu."
557    :type 'hook    :type 'hook
# Line 462  The following additional specs are avail Line 562  The following additional specs are avail
562    :type 'hook    :type 'hook
563    :group 'gnus-article-various)    :group 'gnus-article-various)
564    
565  (defcustom gnus-article-hide-pgp-hook nil  (make-obsolete-variable 'gnus-article-hide-pgp-hook
566    "*A hook called after successfully hiding a PGP signature."                          "This variable is obsolete in Gnus 5.10.")
   :type 'hook  
   :group 'gnus-article-various)  
567    
568  (defcustom gnus-article-button-face 'bold  (defcustom gnus-article-button-face 'bold
569    "Face used for highlighting buttons in the article buffer.    "Face used for highlighting buttons in the article buffer.
# Line 492  Obsolete; use the face `gnus-signature-f Line 590  Obsolete; use the face `gnus-signature-f
590    
591  (defface gnus-signature-face  (defface gnus-signature-face
592    '((t    '((t
593       (:slant italic)))       (:italic t)))
594    "Face used for highlighting a signature in the article buffer."    "Face used for highlighting a signature in the article buffer."
595    :group 'gnus-article-highlight    :group 'gnus-article-highlight
596    :group 'gnus-article-signature)    :group 'gnus-article-signature)
# Line 505  Obsolete; use the face `gnus-signature-f Line 603  Obsolete; use the face `gnus-signature-f
603        (background light))        (background light))
604       (:foreground "red3"))       (:foreground "red3"))
605      (t      (t
606       (:slant italic)))       (:italic t)))
607    "Face used for displaying from headers."    "Face used for displaying from headers."
608    :group 'gnus-article-headers    :group 'gnus-article-headers
609    :group 'gnus-article-highlight)    :group 'gnus-article-highlight)
# Line 518  Obsolete; use the face `gnus-signature-f Line 616  Obsolete; use the face `gnus-signature-f
616        (background light))        (background light))
617       (:foreground "red4"))       (:foreground "red4"))
618      (t      (t
619       (:weight bold :slant italic)))       (:bold t :italic t)))
620    "Face used for displaying subject headers."    "Face used for displaying subject headers."
621    :group 'gnus-article-headers    :group 'gnus-article-headers
622    :group 'gnus-article-highlight)    :group 'gnus-article-highlight)
# Line 526  Obsolete; use the face `gnus-signature-f Line 624  Obsolete; use the face `gnus-signature-f
624  (defface gnus-header-newsgroups-face  (defface gnus-header-newsgroups-face
625    '((((class color)    '((((class color)
626        (background dark))        (background dark))
627       (:foreground "yellow" :slant italic))       (:foreground "yellow" :italic t))
628      (((class color)      (((class color)
629        (background light))        (background light))
630       (:foreground "MidnightBlue" :slant italic))       (:foreground "MidnightBlue" :italic t))
631      (t      (t
632       (:slant italic)))       (:italic t)))
633    "Face used for displaying newsgroups headers."    "Face used for displaying newsgroups headers.
634    In the default setup this face is only used for crossposted
635    articles."
636    :group 'gnus-article-headers    :group 'gnus-article-headers
637    :group 'gnus-article-highlight)    :group 'gnus-article-highlight)
638    
# Line 544  Obsolete; use the face `gnus-signature-f Line 644  Obsolete; use the face `gnus-signature-f
644        (background light))        (background light))
645       (:foreground "maroon"))       (:foreground "maroon"))
646      (t      (t
647       (:weight bold)))       (:bold t)))
648    "Face used for displaying header names."    "Face used for displaying header names."
649    :group 'gnus-article-headers    :group 'gnus-article-headers
650    :group 'gnus-article-highlight)    :group 'gnus-article-highlight)
# Line 552  Obsolete; use the face `gnus-signature-f Line 652  Obsolete; use the face `gnus-signature-f
652  (defface gnus-header-content-face  (defface gnus-header-content-face
653    '((((class color)    '((((class color)
654        (background dark))        (background dark))
655       (:foreground "forest green" :slant italic))       (:foreground "forest green" :italic t))
656      (((class color)      (((class color)
657        (background light))        (background light))
658       (:foreground "indianred4" :slant italic))       (:foreground "indianred4" :italic t))
659      (t      (t
660       (:slant italic)))  "Face used for displaying header content."       (:italic t)))  "Face used for displaying header content."
661    :group 'gnus-article-headers    :group 'gnus-article-headers
662    :group 'gnus-article-highlight)    :group 'gnus-article-highlight)
663    
# Line 566  Obsolete; use the face `gnus-signature-f Line 666  Obsolete; use the face `gnus-signature-f
666      ("Subject" nil gnus-header-subject-face)      ("Subject" nil gnus-header-subject-face)
667      ("Newsgroups:.*," nil gnus-header-newsgroups-face)      ("Newsgroups:.*," nil gnus-header-newsgroups-face)
668      ("" gnus-header-name-face gnus-header-content-face))      ("" gnus-header-name-face gnus-header-content-face))
669    "*Controls highlighting of article header.    "*Controls highlighting of article headers.
670    
671  An alist of the form (HEADER NAME CONTENT).  An alist of the form (HEADER NAME CONTENT).
672    
673  HEADER is a regular expression which should match the name of an  HEADER is a regular expression which should match the name of a
674  header header and NAME and CONTENT are either face names or nil.  header and NAME and CONTENT are either face names or nil.
675    
676  The name of each header field will be displayed using the face  The name of each header field will be displayed using the face
677  specified by the first element in the list where HEADER match the  specified by the first element in the list where HEADER matches
678  header name and NAME is non-nil.  Similarly, the content will be  the header name and NAME is non-nil.  Similarly, the content will
679  displayed by the first non-nil matching CONTENT face."  be displayed by the first non-nil matching CONTENT face."
680    :group 'gnus-article-headers    :group 'gnus-article-headers
681    :group 'gnus-article-highlight    :group 'gnus-article-highlight
682    :type '(repeat (list (regexp :tag "Header")    :type '(repeat (list (regexp :tag "Header")
# Line 588  displayed by the first non-nil matching Line 688  displayed by the first non-nil matching
688                                 (face :value default)))))                                 (face :value default)))))
689    
690  (defcustom gnus-article-decode-hook  (defcustom gnus-article-decode-hook
691    '(article-decode-charset article-decode-encoded-words)    '(article-decode-charset article-decode-encoded-words
692                               article-decode-group-name article-decode-idna-rhs)
693    "*Hook run to decode charsets in articles."    "*Hook run to decode charsets in articles."
694    :group 'gnus-article-headers    :group 'gnus-article-headers
695    :type 'hook)    :type 'hook)
# Line 602  displayed by the first non-nil matching Line 703  displayed by the first non-nil matching
703    "Function used to decode headers.")    "Function used to decode headers.")
704    
705  (defvar gnus-article-dumbquotes-map  (defvar gnus-article-dumbquotes-map
706    '(("\202" ",")    '(("\200" "EUR")
707        ("\202" ",")
708      ("\203" "f")      ("\203" "f")
709      ("\204" ",,")      ("\204" ",,")
710      ("\205" "...")      ("\205" "...")
# Line 615  displayed by the first non-nil matching Line 717  displayed by the first non-nil matching
717      ("\225" "*")      ("\225" "*")
718      ("\226" "-")      ("\226" "-")
719      ("\227" "--")      ("\227" "--")
720        ("\230" "~")
721      ("\231" "(TM)")      ("\231" "(TM)")
722      ("\233" ">")      ("\233" ">")
723      ("\234" "oe")      ("\234" "oe")
# Line 628  displayed by the first non-nil matching Line 731  displayed by the first non-nil matching
731    :type '(repeat regexp))    :type '(repeat regexp))
732    
733  (defcustom gnus-unbuttonized-mime-types '(".*/.*")  (defcustom gnus-unbuttonized-mime-types '(".*/.*")
734    "List of MIME types that should not be given buttons when rendered inline."    "List of MIME types that should not be given buttons when rendered inline.
735    See also `gnus-buttonized-mime-types' which may override this variable.
736    This variable is only used when `gnus-inhibit-mime-unbuttonizing' is nil."
737    :version "21.1"    :version "21.1"
738    :group 'gnus-article-mime    :group 'gnus-article-mime
739    :type '(repeat regexp))    :type '(repeat regexp))
740    
741    (defcustom gnus-buttonized-mime-types nil
742      "List of MIME types that should be given buttons when rendered inline.
743    If set, this variable overrides `gnus-unbuttonized-mime-types'.
744    To see e.g. security buttons you could set this to
745    `(\"multipart/signed\")'.
746    This variable is only used when `gnus-inhibit-mime-unbuttonizing' is nil."
747      :version "21.1"
748      :group 'gnus-article-mime
749      :type '(repeat regexp))
750    
751    (defcustom gnus-inhibit-mime-unbuttonizing nil
752      "If non-nil, all MIME parts get buttons.
753    When nil (the default value), then some MIME parts do not get buttons,
754    as described by the variables `gnus-buttonized-mime-types' and
755    `gnus-unbuttonized-mime-types'."
756      :version "21.3"
757      :type 'boolean)
758    
759    (defcustom gnus-body-boundary-delimiter "_"
760      "String used to delimit header and body.
761    This variable is used by `gnus-article-treat-body-boundary' which can
762    be controlled by `gnus-treat-body-boundary'."
763      :group 'gnus-article-various
764      :type '(choice (item :tag "None" :value nil)
765                     string))
766    
767    (defcustom gnus-picon-databases '("/usr/lib/picon" "/usr/local/faces")
768      "Defines the location of the faces database.
769    For information on obtaining this database of pretty pictures, please
770    see http://www.cs.indiana.edu/picons/ftp/index.html"
771      :type '(repeat directory)
772      :link '(url-link :tag "download"
773                       "http://www.cs.indiana.edu/picons/ftp/index.html")
774      :link '(custom-manual "(gnus)Picons")
775      :group 'gnus-picon)
776    
777    (defun gnus-picons-installed-p ()
778      "Say whether picons are installed on your machine."
779      (let ((installed nil))
780        (dolist (database gnus-picon-databases)
781          (when (file-exists-p database)
782            (setq installed t)))
783        installed))
784    
785  (defcustom gnus-article-mime-part-function nil  (defcustom gnus-article-mime-part-function nil
786    "Function called with a MIME handle as the argument.    "Function called with a MIME handle as the argument.
787  This is meant for people who want to do something automatic based  This is meant for people who want to do something automatic based
# Line 674  used." Line 823  used."
823    
824  (defcustom gnus-mime-action-alist  (defcustom gnus-mime-action-alist
825    '(("save to file" . gnus-mime-save-part)    '(("save to file" . gnus-mime-save-part)
826        ("save and strip" . gnus-mime-save-part-and-strip)
827        ("delete part" . gnus-mime-delete-part)
828      ("display as text" . gnus-mime-inline-part)      ("display as text" . gnus-mime-inline-part)
829      ("view the part" . gnus-mime-view-part)      ("view the part" . gnus-mime-view-part)
830      ("pipe to command" . gnus-mime-pipe-part)      ("pipe to command" . gnus-mime-pipe-part)
831      ("toggle display" . gnus-article-press-button)      ("toggle display" . gnus-article-press-button)
832        ("toggle display" . gnus-article-view-part-as-charset)
833      ("view as type" . gnus-mime-view-part-as-type)      ("view as type" . gnus-mime-view-part-as-type)
834      ("internalize type" . gnus-mime-internalize-part)      ("view internally" . gnus-mime-view-part-internally)
835      ("externalize type" . gnus-mime-externalize-part))      ("view externally" . gnus-mime-view-part-externally))
836    "An alist of actions that run on the MIME attachment."    "An alist of actions that run on the MIME attachment."
   :version "21.1"  
837    :group 'gnus-article-mime    :group 'gnus-article-mime
838    :type '(repeat (cons (string :tag "name")    :type '(repeat (cons (string :tag "name")
839                         (function))))                         (function))))
# Line 713  used." Line 864  used."
864  (defvar gnus-inhibit-treatment nil  (defvar gnus-inhibit-treatment nil
865    "Whether to inhibit treatment.")    "Whether to inhibit treatment.")
866    
867  (defcustom gnus-treat-highlight-signature '(or last (typep "text/x-vcard"))  (defcustom gnus-treat-highlight-signature '(or t (typep "text/x-vcard"))
868    "Highlight the signature.    "Highlight the signature.
869  Valid values are nil, t, `head', `last', an integer or a predicate.  Valid values are nil, t, `head', `last', an integer or a predicate.
870  See the manual for details."  See Info node `(gnus)Customizing Articles'."
871    :group 'gnus-article-treat    :group 'gnus-article-treat
872      :link '(custom-manual "(gnus)Customizing Articles")
873    :type gnus-article-treat-custom)    :type gnus-article-treat-custom)
874  (put 'gnus-treat-highlight-signature 'highlight t)  (put 'gnus-treat-highlight-signature 'highlight t)
875    
876  (defcustom gnus-treat-buttonize 100000  (defcustom gnus-treat-buttonize 100000
877    "Add buttons.    "Add buttons.
878  Valid values are nil, t, `head', `last', an integer or a predicate.  Valid values are nil, t, `head', `last', an integer or a predicate.
879  See the manual for details."  See Info node `(gnus)Customizing Articles'."
880    :group 'gnus-article-treat    :group 'gnus-article-treat
881      :link '(custom-manual "(gnus)Customizing Articles")
882    :type gnus-article-treat-custom)    :type gnus-article-treat-custom)
883  (put 'gnus-treat-buttonize 'highlight t)  (put 'gnus-treat-buttonize 'highlight t)
884    
885  (defcustom gnus-treat-buttonize-head 'head  (defcustom gnus-treat-buttonize-head 'head
886    "Add buttons to the head.    "Add buttons to the head.
887  Valid values are nil, t, `head', `last', an integer or a predicate.  Valid values are nil, t, `head', `last', an integer or a predicate.
888  See the manual for details."  See Info node `(gnus)Customizing Articles' for details."
889    :group 'gnus-article-treat    :group 'gnus-article-treat
890      :link '(custom-manual "(gnus)Customizing Articles")
891    :type gnus-article-treat-head-custom)    :type gnus-article-treat-head-custom)
892  (put 'gnus-treat-buttonize-head 'highlight t)  (put 'gnus-treat-buttonize-head 'highlight t)
893    
# Line 744  See the manual for details." Line 898  See the manual for details."
898         50000)         50000)
899    "Emphasize text.    "Emphasize text.
900  Valid values are nil, t, `head', `last', an integer or a predicate.  Valid values are nil, t, `head', `last', an integer or a predicate.
901  See the manual for details."  See Info node `(gnus)Customizing Articles' for details."
902    :group 'gnus-article-treat    :group 'gnus-article-treat
903      :link '(custom-manual "(gnus)Customizing Articles")
904    :type gnus-article-treat-custom)    :type gnus-article-treat-custom)
905  (put 'gnus-treat-emphasize 'highlight t)  (put 'gnus-treat-emphasize 'highlight t)
906    
907  (defcustom gnus-treat-strip-cr nil  (defcustom gnus-treat-strip-cr nil
908    "Remove carriage returns.    "Remove carriage returns.
909  Valid values are nil, t, `head', `last', an integer or a predicate.  Valid values are nil, t, `head', `last', an integer or a predicate.
910  See the manual for details."  See Info node `(gnus)Customizing Articles' for details."
911      :group 'gnus-article-treat
912      :link '(custom-manual "(gnus)Customizing Articles")
913      :type gnus-article-treat-custom)
914    
915    (defcustom gnus-treat-unsplit-urls nil
916      "Remove newlines from within URLs.
917    Valid values are nil, t, `head', `last', an integer or a predicate.
918    See Info node `(gnus)Customizing Articles' for details."
919    :group 'gnus-article-treat    :group 'gnus-article-treat
920      :link '(custom-manual "(gnus)Customizing Articles")
921      :type gnus-article-treat-custom)
922    
923    (defcustom gnus-treat-leading-whitespace nil
924      "Remove leading whitespace in headers.
925    Valid values are nil, t, `head', `last', an integer or a predicate.
926    See Info node `(gnus)Customizing Articles' for details."
927      :group 'gnus-article-treat
928      :link '(custom-manual "(gnus)Customizing Articles")
929    :type gnus-article-treat-custom)    :type gnus-article-treat-custom)
930    
931  (defcustom gnus-treat-hide-headers 'head  (defcustom gnus-treat-hide-headers 'head
932    "Hide headers.    "Hide headers.
933  Valid values are nil, t, `head', `last', an integer or a predicate.  Valid values are nil, t, `head', `last', an integer or a predicate.
934  See the manual for details."  See Info node `(gnus)Customizing Articles' for details."
935    :group 'gnus-article-treat    :group 'gnus-article-treat
936      :link '(custom-manual "(gnus)Customizing Articles")
937    :type gnus-article-treat-head-custom)    :type gnus-article-treat-head-custom)
938    
939  (defcustom gnus-treat-hide-boring-headers nil  (defcustom gnus-treat-hide-boring-headers nil
940    "Hide boring headers.    "Hide boring headers.
941  Valid values are nil, t, `head', `last', an integer or a predicate.  Valid values are nil, t, `head', `last', an integer or a predicate.
942  See the manual for details."  See Info node `(gnus)Customizing Articles' for details."
943    :group 'gnus-article-treat    :group 'gnus-article-treat
944      :link '(custom-manual "(gnus)Customizing Articles")
945    :type gnus-article-treat-head-custom)    :type gnus-article-treat-head-custom)
946    
947  (defcustom gnus-treat-hide-signature nil  (defcustom gnus-treat-hide-signature nil
948    "Hide the signature.    "Hide the signature.
949  Valid values are nil, t, `head', `last', an integer or a predicate.  Valid values are nil, t, `head', `last', an integer or a predicate.
950  See the manual for details."  See Info node `(gnus)Customizing Articles' for details."
951    :group 'gnus-article-treat    :group 'gnus-article-treat
952      :link '(custom-manual "(gnus)Customizing Articles")
953    :type gnus-article-treat-custom)    :type gnus-article-treat-custom)
954    
955  (defcustom gnus-treat-fill-article nil  (defcustom gnus-treat-fill-article nil
956    "Fill the article.    "Fill the article.
957  Valid values are nil, t, `head', `last', an integer or a predicate.  Valid values are nil, t, `head', `last', an integer or a predicate.
958  See the manual for details."  See Info node `(gnus)Customizing Articles' for details."
959    :group 'gnus-article-treat    :group 'gnus-article-treat
960      :link '(custom-manual "(gnus)Customizing Articles")
961    :type gnus-article-treat-custom)    :type gnus-article-treat-custom)
962    
963  (defcustom gnus-treat-hide-citation nil  (defcustom gnus-treat-hide-citation nil
964    "Hide cited text.    "Hide cited text.
965  Valid values are nil, t, `head', `last', an integer or a predicate.  Valid values are nil, t, `head', `last', an integer or a predicate.
966  See the manual for details."  See Info node `(gnus)Customizing Articles' for details."
967    :group 'gnus-article-treat    :group 'gnus-article-treat
968      :link '(custom-manual "(gnus)Customizing Articles")
969    :type gnus-article-treat-custom)    :type gnus-article-treat-custom)
970    
971  (defcustom gnus-treat-hide-citation-maybe nil  (defcustom gnus-treat-hide-citation-maybe nil
972    "Hide cited text.    "Hide cited text.
973  Valid values are nil, t, `head', `last', an integer or a predicate.  Valid values are nil, t, `head', `last', an integer or a predicate.
974  See the manual for details."  See Info node `(gnus)Customizing Articles' for details."
975    :group 'gnus-article-treat    :group 'gnus-article-treat
976      :link '(custom-manual "(gnus)Customizing Articles")
977    :type gnus-article-treat-custom)    :type gnus-article-treat-custom)
978    
979  (defcustom gnus-treat-strip-list-identifiers 'head  (defcustom gnus-treat-strip-list-identifiers 'head
980    "Strip list identifiers from `gnus-list-identifiers`.    "Strip list identifiers from `gnus-list-identifiers`.
981  Valid values are nil, t, `head', `last', an integer or a predicate.  Valid values are nil, t, `head', `last', an integer or a predicate.
982  See the manual for details."  See Info node `(gnus)Customizing Articles' for details."
983    :version "21.1"    :version "21.1"
984    :group 'gnus-article-treat    :group 'gnus-article-treat
985      :link '(custom-manual "(gnus)Customizing Articles")
986    :type gnus-article-treat-custom)    :type gnus-article-treat-custom)
987    
988  (defcustom gnus-treat-strip-pgp t  (make-obsolete-variable 'gnus-treat-strip-pgp
989    "Strip PGP signatures.                          "This option is obsolete in Gnus 5.10.")
 Valid values are nil, t, `head', `last', an integer or a predicate.  
 See the manual for details."  
   :group 'gnus-article-treat  
   :type gnus-article-treat-custom)  
990    
991  (defcustom gnus-treat-strip-pem nil  (defcustom gnus-treat-strip-pem nil
992    "Strip PEM signatures.    "Strip PEM signatures.
993  Valid values are nil, t, `head', `last', an integer or a predicate.  Valid values are nil, t, `head', `last', an integer or a predicate.
994  See the manual for details."  See Info node `(gnus)Customizing Articles' for details."
995    :group 'gnus-article-treat    :group 'gnus-article-treat
996      :link '(custom-manual "(gnus)Customizing Articles")
997    :type gnus-article-treat-custom)    :type gnus-article-treat-custom)
998    
999  (defcustom gnus-treat-strip-banner t  (defcustom gnus-treat-strip-banner t
1000    "Strip banners from articles.    "Strip banners from articles.
1001  The banner to be stripped is specified in the `banner' group parameter.  The banner to be stripped is specified in the `banner' group parameter.
1002  Valid values are nil, t, `head', `last', an integer or a predicate.  Valid values are nil, t, `head', `last', an integer or a predicate.
1003  See the manual for details."  See Info node `(gnus)Customizing Articles' for details."
1004    :group 'gnus-article-treat    :group 'gnus-article-treat
1005      :link '(custom-manual "(gnus)Customizing Articles")
1006    :type gnus-article-treat-custom)    :type gnus-article-treat-custom)
1007    
1008  (defcustom gnus-treat-highlight-headers 'head  (defcustom gnus-treat-highlight-headers 'head
1009    "Highlight the headers.    "Highlight the headers.
1010  Valid values are nil, t, `head', `last', an integer or a predicate.  Valid values are nil, t, `head', `last', an integer or a predicate.
1011  See the manual for details."  See Info node `(gnus)Customizing Articles' for details."
1012    :group 'gnus-article-treat    :group 'gnus-article-treat
1013      :link '(custom-manual "(gnus)Customizing Articles")
1014    :type gnus-article-treat-head-custom)    :type gnus-article-treat-head-custom)
1015  (put 'gnus-treat-highlight-headers 'highlight t)  (put 'gnus-treat-highlight-headers 'highlight t)
1016    
1017  (defcustom gnus-treat-highlight-citation t  (defcustom gnus-treat-highlight-citation t
1018    "Highlight cited text.    "Highlight cited text.
1019  Valid values are nil, t, `head', `last', an integer or a predicate.  Valid values are nil, t, `head', `last', an integer or a predicate.
1020  See the manual for details."  See Info node `(gnus)Customizing Articles' for details."
1021    :group 'gnus-article-treat    :group 'gnus-article-treat
1022      :link '(custom-manual "(gnus)Customizing Articles")
1023    :type gnus-article-treat-custom)    :type gnus-article-treat-custom)
1024  (put 'gnus-treat-highlight-citation 'highlight t)  (put 'gnus-treat-highlight-citation 'highlight t)
1025    
1026  (defcustom gnus-treat-date-ut nil  (defcustom gnus-treat-date-ut nil
1027    "Display the Date in UT (GMT).    "Display the Date in UT (GMT).
1028  Valid values are nil, t, `head', `last', an integer or a predicate.  Valid values are nil, t, `head', `last', an integer or a predicate.
1029  See the manual for details."  See Info node `(gnus)Customizing Articles' for details."
1030    :group 'gnus-article-treat    :group 'gnus-article-treat
1031      :link '(custom-manual "(gnus)Customizing Articles")
1032    :type gnus-article-treat-head-custom)    :type gnus-article-treat-head-custom)
1033    
1034  (defcustom gnus-treat-date-local nil  (defcustom gnus-treat-date-local nil
1035    "Display the Date in the local timezone.    "Display the Date in the local timezone.
1036  Valid values are nil, t, `head', `last', an integer or a predicate.  Valid values are nil, t, `head', `last', an integer or a predicate.
1037  See the manual for details."  See Info node `(gnus)Customizing Articles' for details."
1038    :group 'gnus-article-treat    :group 'gnus-article-treat
1039      :link '(custom-manual "(gnus)Customizing Articles")
1040      :type gnus-article-treat-head-custom)
1041    
1042    (defcustom gnus-treat-date-english nil
1043      "Display the Date in a format that can be read aloud in English.
1044    Valid values are nil, t, `head', `last', an integer or a predicate.
1045    See Info node `(gnus)Customizing Articles' for details."
1046      :group 'gnus-article-treat
1047      :link '(custom-manual "(gnus)Customizing Articles")
1048    :type gnus-article-treat-head-custom)    :type gnus-article-treat-head-custom)
1049    
1050  (defcustom gnus-treat-date-lapsed nil  (defcustom gnus-treat-date-lapsed nil
1051    "Display the Date header in a way that says how much time has elapsed.    "Display the Date header in a way that says how much time has elapsed.
1052  Valid values are nil, t, `head', `last', an integer or a predicate.  Valid values are nil, t, `head', `last', an integer or a predicate.
1053  See the manual for details."  See Info node `(gnus)Customizing Articles' for details."
1054    :group 'gnus-article-treat    :group 'gnus-article-treat
1055      :link '(custom-manual "(gnus)Customizing Articles")
1056    :type gnus-article-treat-head-custom)    :type gnus-article-treat-head-custom)
1057    
1058  (defcustom gnus-treat-date-original nil  (defcustom gnus-treat-date-original nil
1059    "Display the date in the original timezone.    "Display the date in the original timezone.
1060  Valid values are nil, t, `head', `last', an integer or a predicate.  Valid values are nil, t, `head', `last', an integer or a predicate.
1061  See the manual for details."  See Info node `(gnus)Customizing Articles' for details."
1062    :group 'gnus-article-treat    :group 'gnus-article-treat
1063      :link '(custom-manual "(gnus)Customizing Articles")
1064    :type gnus-article-treat-head-custom)    :type gnus-article-treat-head-custom)
1065    
1066  (defcustom gnus-treat-date-iso8601 nil  (defcustom gnus-treat-date-iso8601 nil
1067    "Display the date in the ISO8601 format.    "Display the date in the ISO8601 format.
1068  Valid values are nil, t, `head', `last', an integer or a predicate.  Valid values are nil, t, `head', `last', an integer or a predicate.
1069  See the manual for details."  See Info node `(gnus)Customizing Articles' for details."
1070    :version "21.1"    :version "21.1"
1071    :group 'gnus-article-treat    :group 'gnus-article-treat
1072      :link '(custom-manual "(gnus)Customizing Articles")
1073    :type gnus-article-treat-head-custom)    :type gnus-article-treat-head-custom)
1074    
1075  (defcustom gnus-treat-date-user-defined nil  (defcustom gnus-treat-date-user-defined nil
1076    "Display the date in a user-defined format.    "Display the date in a user-defined format.
1077  The format is defined by the `gnus-article-time-format' variable.  The format is defined by the `gnus-article-time-format' variable.
1078  Valid values are nil, t, `head', `last', an integer or a predicate.  Valid values are nil, t, `head', `last', an integer or a predicate.
1079  See the manual for details."  See Info node `(gnus)Customizing Articles' for details."
1080    :group 'gnus-article-treat    :group 'gnus-article-treat
1081      :link '(custom-manual "(gnus)Customizing Articles")
1082    :type gnus-article-treat-head-custom)    :type gnus-article-treat-head-custom)
1083    
1084  (defcustom gnus-treat-strip-headers-in-body t  (defcustom gnus-treat-strip-headers-in-body t
1085    "Strip the X-No-Archive header line from the beginning of the body.    "Strip the X-No-Archive header line from the beginning of the body.
1086  Valid values are nil, t, `head', `last', an integer or a predicate.  Valid values are nil, t, `head', `last', an integer or a predicate.
1087  See the manual for details."  See Info node `(gnus)Customizing Articles' for details."
1088    :version "21.1"    :version "21.1"
1089    :group 'gnus-article-treat    :group 'gnus-article-treat
1090      :link '(custom-manual "(gnus)Customizing Articles")
1091    :type gnus-article-treat-custom)    :type gnus-article-treat-custom)
1092    
1093  (defcustom gnus-treat-strip-trailing-blank-lines nil  (defcustom gnus-treat-strip-trailing-blank-lines nil
1094    "Strip trailing blank lines.    "Strip trailing blank lines.
1095  Valid values are nil, t, `head', `last', an integer or a predicate.  Valid values are nil, t, `head', `last', an integer or a predicate.
1096  See the manual for details."  See Info node `(gnus)Customizing Articles' for details."
1097    :group 'gnus-article-treat    :group 'gnus-article-treat
1098      :link '(custom-manual "(gnus)Customizing Articles")
1099    :type gnus-article-treat-custom)    :type gnus-article-treat-custom)
1100    
1101  (defcustom gnus-treat-strip-leading-blank-lines nil  (defcustom gnus-treat-strip-leading-blank-lines nil
1102    "Strip leading blank lines.    "Strip leading blank lines.
1103  Valid values are nil, t, `head', `last', an integer or a predicate.  Valid values are nil, t, `head', `last', an integer or a predicate.
1104  See the manual for details."  See Info node `(gnus)Customizing Articles' for details."
1105    :group 'gnus-article-treat    :group 'gnus-article-treat
1106      :link '(custom-manual "(gnus)Customizing Articles")
1107    :type gnus-article-treat-custom)    :type gnus-article-treat-custom)
1108    
1109  (defcustom gnus-treat-strip-multiple-blank-lines nil  (defcustom gnus-treat-strip-multiple-blank-lines nil
1110    "Strip multiple blank lines.    "Strip multiple blank lines.
1111  Valid values are nil, t, `head', `last', an integer or a predicate.  Valid values are nil, t, `head', `last', an integer or a predicate.
1112  See the manual for details."  See Info node `(gnus)Customizing Articles' for details."
1113      :group 'gnus-article-treat
1114      :link '(custom-manual "(gnus)Customizing Articles")
1115      :type gnus-article-treat-custom)
1116    
1117    (defcustom gnus-treat-unfold-headers 'head
1118      "Unfold folded header lines.
1119    Valid values are nil, t, `head', `last', an integer or a predicate.
1120    See Info node `(gnus)Customizing Articles' for details."
1121      :group 'gnus-article-treat
1122      :link '(custom-manual "(gnus)Customizing Articles")
1123      :type gnus-article-treat-custom)
1124    
1125    (defcustom gnus-treat-fold-headers nil
1126      "Fold headers.
1127    Valid values are nil, t, `head', `last', an integer or a predicate.
1128    See Info node `(gnus)Customizing Articles' for details."
1129      :group 'gnus-article-treat
1130      :link '(custom-manual "(gnus)Customizing Articles")
1131      :type gnus-article-treat-custom)
1132    
1133    (defcustom gnus-treat-fold-newsgroups 'head
1134      "Fold the Newsgroups and Followup-To headers.
1135    Valid values are nil, t, `head', `last', an integer or a predicate.
1136    See Info node `(gnus)Customizing Articles' for details."
1137    :group 'gnus-article-treat    :group 'gnus-article-treat
1138      :link '(custom-manual "(gnus)Customizing Articles")
1139    :type gnus-article-treat-custom)    :type gnus-article-treat-custom)
1140    
1141  (defcustom gnus-treat-overstrike t  (defcustom gnus-treat-overstrike t
1142    "Treat overstrike highlighting.    "Treat overstrike highlighting.
1143  Valid values are nil, t, `head', `last', an integer or a predicate.  Valid values are nil, t, `head', `last', an integer or a predicate.
1144  See the manual for details."  See Info node `(gnus)Customizing Articles' for details."
1145    :group 'gnus-article-treat    :group 'gnus-article-treat
1146      :link '(custom-manual "(gnus)Customizing Articles")
1147    :type gnus-article-treat-custom)    :type gnus-article-treat-custom)
1148  (put 'gnus-treat-overstrike 'highlight t)  (put 'gnus-treat-overstrike 'highlight t)
1149    
1150  (defcustom gnus-treat-display-xface  (make-obsolete-variable 'gnus-treat-display-xface
1151    (and (or (and (fboundp 'image-type-available-p)                          'gnus-treat-display-x-face)
1152    
1153    (defcustom gnus-treat-display-x-face
1154      (and (not noninteractive)
1155           (or (and (fboundp 'image-type-available-p)
1156                  (image-type-available-p 'xbm)                  (image-type-available-p 'xbm)
1157                  (string-match "^0x" (shell-command-to-string "uncompface")))                  (string-match "^0x" (shell-command-to-string "uncompface"))
1158             (and (featurep 'xemacs) (featurep 'xface)))                  (executable-find "icontopbm"))
1159               (and (featurep 'xemacs)
1160                    (featurep 'xface)))
1161         'head)         'head)
1162    "Display X-Face headers.    "Display X-Face headers.
1163  Valid values are nil, t, `head', `last', an integer or a predicate.  Valid values are nil, t, `head', `last', an integer or a predicate.
1164  See the manual for details."  See Info node `(gnus)Customizing Articles' and Info node
1165    `(gnus)X-Face' for details."
1166      :group 'gnus-article-treat
1167      :version "21.1"
1168      :link '(custom-manual "(gnus)Customizing Articles")
1169      :link '(custom-manual "(gnus)X-Face")
1170      :type gnus-article-treat-head-custom
1171      :set (lambda (symbol value)
1172             (set-default
1173              symbol
1174              (cond ((or (boundp symbol) (get symbol 'saved-value))
1175                     value)
1176                    ((boundp 'gnus-treat-display-xface)
1177                     (message "\
1178    ** gnus-treat-display-xface is an obsolete variable;\
1179     use gnus-treat-display-x-face instead")
1180                     (default-value 'gnus-treat-display-xface))
1181                    ((get 'gnus-treat-display-xface 'saved-value)
1182                     (message "\
1183    ** gnus-treat-display-xface is an obsolete variable;\
1184     use gnus-treat-display-x-face instead")
1185                     (eval (car (get 'gnus-treat-display-xface 'saved-value))))
1186                    (t
1187                     value)))))
1188    (put 'gnus-treat-display-x-face 'highlight t)
1189    
1190    (defcustom gnus-treat-display-face
1191      (and (not noninteractive)
1192           (or (and (fboundp 'image-type-available-p)
1193                    (image-type-available-p 'png))
1194               (and (featurep 'xemacs)
1195                    (featurep 'png)))
1196           'head)
1197      "Display Face headers.
1198    Valid values are nil, t, `head', `last', an integer or a predicate.
1199    See Info node `(gnus)Customizing Articles' and Info node
1200    `(gnus)X-Face' for details."
1201    :group 'gnus-article-treat    :group 'gnus-article-treat
1202    :version "21.1"    :version "21.1"
1203      :link '(custom-manual "(gnus)Customizing Articles")
1204      :link '(custom-manual "(gnus)X-Face")
1205    :type gnus-article-treat-head-custom)    :type gnus-article-treat-head-custom)
1206  (put 'gnus-treat-display-xface 'highlight t)  (put 'gnus-treat-display-face 'highlight t)
1207    
1208  (defcustom gnus-treat-display-smileys  (defcustom gnus-treat-display-smileys
1209    (if (or (and (featurep 'xemacs)    (if (or (and (featurep 'xemacs)
# Line 947  See the manual for details." Line 1213  See the manual for details."
1213        t nil)        t nil)
1214    "Display smileys.    "Display smileys.
1215  Valid values are nil, t, `head', `last', an integer or a predicate.  Valid values are nil, t, `head', `last', an integer or a predicate.
1216  See the manual for details."  See Info node `(gnus)Customizing Articles' and Info node
1217    `(gnus)Smileys' for details."
1218    :group 'gnus-article-treat    :group 'gnus-article-treat
1219    :version "21.1"    :version "21.1"
1220      :link '(custom-manual "(gnus)Customizing Articles")
1221      :link '(custom-manual "(gnus)Smileys")
1222    :type gnus-article-treat-custom)    :type gnus-article-treat-custom)
1223  (put 'gnus-treat-display-smileys 'highlight t)  (put 'gnus-treat-display-smileys 'highlight t)
1224    
1225  (defcustom gnus-treat-display-picons (if (featurep 'xemacs) 'head nil)  (defcustom gnus-treat-from-picon
1226    "Display picons.    (if (and (gnus-image-type-available-p 'xpm)
1227               (gnus-picons-installed-p))
1228          'head nil)
1229      "Display picons in the From header.
1230  Valid values are nil, t, `head', `last', an integer or a predicate.  Valid values are nil, t, `head', `last', an integer or a predicate.
1231  See the manual for details."  See Info node `(gnus)Customizing Articles' and Info node
1232    `(gnus)Picons' for details."
1233    :group 'gnus-article-treat    :group 'gnus-article-treat
1234      :group 'gnus-picon
1235      :link '(custom-manual "(gnus)Customizing Articles")
1236      :link '(custom-manual "(gnus)Picons")
1237      :type gnus-article-treat-head-custom)
1238    (put 'gnus-treat-from-picon 'highlight t)
1239    
1240    (defcustom gnus-treat-mail-picon
1241      (if (and (gnus-image-type-available-p 'xpm)
1242               (gnus-picons-installed-p))
1243          'head nil)
1244      "Display picons in To and Cc headers.
1245    Valid values are nil, t, `head', `last', an integer or a predicate.
1246    See Info node `(gnus)Customizing Articles' and Info node
1247    `(gnus)Picons' for details."
1248      :group 'gnus-article-treat
1249      :group 'gnus-picon
1250      :link '(custom-manual "(gnus)Customizing Articles")
1251      :link '(custom-manual "(gnus)Picons")
1252      :type gnus-article-treat-head-custom)
1253    (put 'gnus-treat-mail-picon 'highlight t)
1254    
1255    (defcustom gnus-treat-newsgroups-picon
1256      (if (and (gnus-image-type-available-p 'xpm)
1257               (gnus-picons-installed-p))
1258          'head nil)
1259      "Display picons in the Newsgroups and Followup-To headers.
1260    Valid values are nil, t, `head', `last', an integer or a predicate.
1261    See Info node `(gnus)Customizing Articles' and Info node
1262    `(gnus)Picons' for details."
1263      :group 'gnus-article-treat
1264      :group 'gnus-picon
1265      :link '(custom-manual "(gnus)Customizing Articles")
1266      :link '(custom-manual "(gnus)Picons")
1267      :type gnus-article-treat-head-custom)
1268    (put 'gnus-treat-newsgroups-picon 'highlight t)
1269    
1270    (defcustom gnus-treat-body-boundary
1271      (if (or gnus-treat-newsgroups-picon
1272              gnus-treat-mail-picon
1273              gnus-treat-from-picon)
1274          'head nil)
1275      "Draw a boundary at the end of the headers.
1276    Valid values are nil and `head'.
1277    See Info node `(gnus)Customizing Articles' for details."
1278      :version "21.1"
1279      :group 'gnus-article-treat
1280      :link '(custom-manual "(gnus)Customizing Articles")
1281    :type gnus-article-treat-head-custom)    :type gnus-article-treat-head-custom)
 (put 'gnus-treat-display-picons 'highlight t)  
1282    
1283  (defcustom gnus-treat-capitalize-sentences nil  (defcustom gnus-treat-capitalize-sentences nil
1284    "Capitalize sentence-starting words.    "Capitalize sentence-starting words.
1285  Valid values are nil, t, `head', `last', an integer or a predicate.  Valid values are nil, t, `head', `last', an integer or a predicate.
1286  See the manual for details."  See Info node `(gnus)Customizing Articles' for details."
1287    :version "21.1"    :version "21.1"
1288    :group 'gnus-article-treat    :group 'gnus-article-treat
1289      :link '(custom-manual "(gnus)Customizing Articles")
1290      :type gnus-article-treat-custom)
1291    
1292    (defcustom gnus-treat-wash-html nil
1293      "Format as HTML.
1294    Valid values are nil, t, `head', `last', an integer or a predicate.
1295    See Info node `(gnus)Customizing Articles' for details."
1296      :group 'gnus-article-treat
1297      :link '(custom-manual "(gnus)Customizing Articles")
1298    :type gnus-article-treat-custom)    :type gnus-article-treat-custom)
1299    
1300  (defcustom gnus-treat-fill-long-lines nil  (defcustom gnus-treat-fill-long-lines nil
1301    "Fill long lines.    "Fill long lines.
1302  Valid values are nil, t, `head', `last', an integer or a predicate.  Valid values are nil, t, `head', `last', an integer or a predicate.
1303  See the manual for details."  See Info node `(gnus)Customizing Articles' for details."
1304    :group 'gnus-article-treat    :group 'gnus-article-treat
1305      :link '(custom-manual "(gnus)Customizing Articles")
1306    :type gnus-article-treat-custom)    :type gnus-article-treat-custom)
1307    
1308  (defcustom gnus-treat-play-sounds nil  (defcustom gnus-treat-play-sounds nil
1309    "Play sounds.    "Play sounds.
1310  Valid values are nil, t, `head', `last', an integer or a predicate.  Valid values are nil, t, `head', `last', an integer or a predicate.
1311  See the manual for details."  See Info node `(gnus)Customizing Articles' for details."
1312    :version "21.1"    :version "21.1"
1313    :group 'gnus-article-treat    :group 'gnus-article-treat
1314      :link '(custom-manual "(gnus)Customizing Articles")
1315    :type gnus-article-treat-custom)    :type gnus-article-treat-custom)
1316    
1317  (defcustom gnus-treat-translate nil  (defcustom gnus-treat-translate nil
1318    "Translate articles from one language to another.    "Translate articles from one language to another.
1319  Valid values are nil, t, `head', `last', an integer or a predicate.  Valid values are nil, t, `head', `last', an integer or a predicate.
1320  See the manual for details."  See Info node `(gnus)Customizing Articles' for details."
1321    :version "21.1"    :version "21.1"
1322    :group 'gnus-article-treat    :group 'gnus-article-treat
1323      :link '(custom-manual "(gnus)Customizing Articles")
1324    :type gnus-article-treat-custom)    :type gnus-article-treat-custom)
1325    
1326    (defcustom gnus-treat-x-pgp-sig nil
1327      "Verify X-PGP-Sig.
1328    To automatically treat X-PGP-Sig, set it to head.
1329    Valid values are nil, t, `head', `last', an integer or a predicate.
1330    See Info node `(gnus)Customizing Articles' for details."
1331      :group 'gnus-article-treat
1332      :group 'mime-security
1333      :link '(custom-manual "(gnus)Customizing Articles")
1334      :type gnus-article-treat-custom)
1335    
1336    (defvar gnus-article-encrypt-protocol-alist
1337      '(("PGP" . mml2015-self-encrypt)))
1338    
1339    ;; Set to nil if more than one protocol added to
1340    ;; gnus-article-encrypt-protocol-alist.
1341    (defcustom gnus-article-encrypt-protocol "PGP"
1342      "The protocol used for encrypt articles.
1343    It is a string, such as \"PGP\". If nil, ask user."
1344      :type 'string
1345      :group 'mime-security)
1346    
1347    (defvar gnus-article-wash-function nil
1348      "Function used for converting HTML into text.")
1349    
1350    (defcustom gnus-use-idna (and (condition-case nil (require 'idna) (file-error))
1351                                  (mm-coding-system-p 'utf-8)
1352                                  (executable-find idna-program))
1353      "Whether IDNA decoding of headers is used when viewing messages.
1354    This requires GNU Libidn, and by default only enabled if it is found."
1355      :group 'gnus-article-headers
1356      :type 'boolean)
1357    
1358    (defcustom gnus-article-over-scroll nil
1359      "If non-nil, allow scrolling the article buffer even when there no more text."
1360      :group 'gnus-article
1361      :type 'boolean)
1362    
1363  ;;; Internal variables  ;;; Internal variables
1364    
1365    (defvar gnus-english-month-names
1366      '("January" "February" "March" "April" "May" "June" "July" "August"
1367        "September" "October" "November" "December"))
1368    
1369  (defvar article-goto-body-goes-to-point-min-p nil)  (defvar article-goto-body-goes-to-point-min-p nil)
1370  (defvar gnus-article-wash-types nil)  (defvar gnus-article-wash-types nil)
1371  (defvar gnus-article-emphasis-alist nil)  (defvar gnus-article-emphasis-alist nil)
1372    (defvar gnus-article-image-alist nil)
1373    
1374  (defvar gnus-article-mime-handle-alist-1 nil)  (defvar gnus-article-mime-handle-alist-1 nil)
1375  (defvar gnus-treatment-function-alist  (defvar gnus-treatment-function-alist
1376    '((gnus-treat-strip-banner gnus-article-strip-banner)    '((gnus-treat-x-pgp-sig gnus-article-verify-x-pgp-sig)
1377        (gnus-treat-strip-banner gnus-article-strip-banner)
1378      (gnus-treat-strip-headers-in-body gnus-article-strip-headers-in-body)      (gnus-treat-strip-headers-in-body gnus-article-strip-headers-in-body)
1379      (gnus-treat-highlight-signature gnus-article-highlight-signature)      (gnus-treat-highlight-signature gnus-article-highlight-signature)
1380      (gnus-treat-buttonize gnus-article-add-buttons)      (gnus-treat-buttonize gnus-article-add-buttons)
1381      (gnus-treat-fill-article gnus-article-fill-cited-article)      (gnus-treat-fill-article gnus-article-fill-cited-article)
1382      (gnus-treat-fill-long-lines gnus-article-fill-long-lines)      (gnus-treat-fill-long-lines gnus-article-fill-long-lines)
1383      (gnus-treat-strip-cr gnus-article-remove-cr)      (gnus-treat-strip-cr gnus-article-remove-cr)
1384      (gnus-treat-emphasize gnus-article-emphasize)      (gnus-treat-unsplit-urls gnus-article-unsplit-urls)
1385      (gnus-treat-display-xface gnus-article-display-x-face)      (gnus-treat-date-ut gnus-article-date-ut)
1386        (gnus-treat-date-local gnus-article-date-local)
1387        (gnus-treat-date-english gnus-article-date-english)
1388        (gnus-treat-date-lapsed gnus-article-date-lapsed)
1389        (gnus-treat-date-original gnus-article-date-original)
1390        (gnus-treat-date-user-defined gnus-article-date-user)
1391        (gnus-treat-date-iso8601 gnus-article-date-iso8601)
1392        (gnus-treat-display-x-face gnus-article-display-x-face)
1393        (gnus-treat-display-face gnus-article-display-face)
1394      (gnus-treat-hide-headers gnus-article-maybe-hide-headers)      (gnus-treat-hide-headers gnus-article-maybe-hide-headers)
1395      (gnus-treat-hide-boring-headers gnus-article-hide-boring-headers)      (gnus-treat-hide-boring-headers gnus-article-hide-boring-headers)
1396      (gnus-treat-hide-signature gnus-article-hide-signature)      (gnus-treat-hide-signature gnus-article-hide-signature)
     (gnus-treat-hide-citation gnus-article-hide-citation)  
     (gnus-treat-hide-citation-maybe gnus-article-hide-citation-maybe)  
1397      (gnus-treat-strip-list-identifiers gnus-article-hide-list-identifiers)      (gnus-treat-strip-list-identifiers gnus-article-hide-list-identifiers)
1398      (gnus-treat-strip-pgp gnus-article-hide-pgp)      (gnus-treat-leading-whitespace gnus-article-remove-leading-whitespace)
1399      (gnus-treat-strip-pem gnus-article-hide-pem)      (gnus-treat-strip-pem gnus-article-hide-pem)
1400        (gnus-treat-from-picon gnus-treat-from-picon)
1401        (gnus-treat-mail-picon gnus-treat-mail-picon)
1402        (gnus-treat-newsgroups-picon gnus-treat-newsgroups-picon)
1403      (gnus-treat-highlight-headers gnus-article-highlight-headers)      (gnus-treat-highlight-headers gnus-article-highlight-headers)
     (gnus-treat-highlight-citation gnus-article-highlight-citation)  
1404      (gnus-treat-highlight-signature gnus-article-highlight-signature)      (gnus-treat-highlight-signature gnus-article-highlight-signature)
     (gnus-treat-date-ut gnus-article-date-ut)  
     (gnus-treat-date-local gnus-article-date-local)  
     (gnus-treat-date-lapsed gnus-article-date-lapsed)  
     (gnus-treat-date-original gnus-article-date-original)  
     (gnus-treat-date-user-defined gnus-article-date-user)  
     (gnus-treat-date-iso8601 gnus-article-date-iso8601)  
1405      (gnus-treat-strip-trailing-blank-lines      (gnus-treat-strip-trailing-blank-lines
1406       gnus-article-remove-trailing-blank-lines)       gnus-article-remove-trailing-blank-lines)
1407      (gnus-treat-strip-leading-blank-lines      (gnus-treat-strip-leading-blank-lines
# Line 1033  See the manual for details." Line 1409  See the manual for details."
1409      (gnus-treat-strip-multiple-blank-lines      (gnus-treat-strip-multiple-blank-lines
1410       gnus-article-strip-multiple-blank-lines)       gnus-article-strip-multiple-blank-lines)
1411      (gnus-treat-overstrike gnus-article-treat-overstrike)      (gnus-treat-overstrike gnus-article-treat-overstrike)
1412        (gnus-treat-unfold-headers gnus-article-treat-unfold-headers)
1413        (gnus-treat-fold-headers gnus-article-treat-fold-headers)
1414        (gnus-treat-fold-newsgroups gnus-article-treat-fold-newsgroups)
1415      (gnus-treat-buttonize-head gnus-article-add-buttons-to-head)      (gnus-treat-buttonize-head gnus-article-add-buttons-to-head)
1416      (gnus-treat-display-smileys gnus-smiley-display)      (gnus-treat-display-smileys gnus-treat-smiley)
1417      (gnus-treat-capitalize-sentences gnus-article-capitalize-sentences)      (gnus-treat-capitalize-sentences gnus-article-capitalize-sentences)
1418      (gnus-treat-display-picons gnus-article-display-picons)      (gnus-treat-wash-html gnus-article-wash-html)
1419        (gnus-treat-emphasize gnus-article-emphasize)
1420        (gnus-treat-hide-citation gnus-article-hide-citation)
1421        (gnus-treat-hide-citation-maybe gnus-article-hide-citation-maybe)
1422        (gnus-treat-highlight-citation gnus-article-highlight-citation)
1423        (gnus-treat-body-boundary gnus-article-treat-body-boundary)
1424      (gnus-treat-play-sounds gnus-earcon-display)))      (gnus-treat-play-sounds gnus-earcon-display)))
1425    
1426  (defvar gnus-article-mime-handle-alist nil)  (defvar gnus-article-mime-handle-alist nil)
# Line 1045  See the manual for details." Line 1429  See the manual for details."
1429    
1430  (defvar gnus-article-mode-syntax-table  (defvar gnus-article-mode-syntax-table
1431    (let ((table (copy-syntax-table text-mode-syntax-table)))    (let ((table (copy-syntax-table text-mode-syntax-table)))
1432      (modify-syntax-entry ?- "w" table)      ;; This causes the citation match run O(2^n).
1433      (modify-syntax-entry ?> ")" table)      ;; (modify-syntax-entry ?- "w" table)
1434      (modify-syntax-entry ?< "(" table)      (modify-syntax-entry ?> ")<" table)
1435        (modify-syntax-entry ?< "(>" table)
1436        ;; make M-. in article buffers work for `foo' strings
1437        (modify-syntax-entry ?' " " table)
1438        (modify-syntax-entry ?` " " table)
1439      table)      table)
1440    "Syntax table used in article mode buffers.    "Syntax table used in article mode buffers.
1441  Initialized from `text-mode-syntax-table.")  Initialized from `text-mode-syntax-table.")
# Line 1063  Initialized from `text-mode-syntax-table Line 1451  Initialized from `text-mode-syntax-table
1451    
1452  (defvar gnus-inhibit-hiding nil)  (defvar gnus-inhibit-hiding nil)
1453    
1454    ;;; Macros for dealing with the article buffer.
1455    
1456    (defmacro gnus-with-article-headers (&rest forms)
1457      `(save-excursion
1458         (set-buffer gnus-article-buffer)
1459         (save-restriction
1460           (let ((inhibit-read-only t)
1461                 (inhibit-point-motion-hooks t)
1462                 (case-fold-search t))
1463             (article-narrow-to-head)
1464             ,@forms))))
1465    
1466    (put 'gnus-with-article-headers 'lisp-indent-function 0)
1467    (put 'gnus-with-article-headers 'edebug-form-spec '(body))
1468    
1469    (defmacro gnus-with-article-buffer (&rest forms)
1470      `(save-excursion
1471         (set-buffer gnus-article-buffer)
1472         (let ((inhibit-read-only t))
1473           ,@forms)))
1474    
1475    (put 'gnus-with-article-buffer 'lisp-indent-function 0)
1476    (put 'gnus-with-article-buffer 'edebug-form-spec '(body))
1477    
1478    (defun gnus-article-goto-header (header)
1479      "Go to HEADER, which is a regular expression."
1480      (re-search-forward (concat "^\\(" header "\\):") nil t))
1481    
1482  (defsubst gnus-article-hide-text (b e props)  (defsubst gnus-article-hide-text (b e props)
1483    "Set text PROPS on the B to E region, extending `intangible' 1 past B."    "Set text PROPS on the B to E region, extending `intangible' 1 past B."
1484    (gnus-add-text-properties-when 'article-type nil b e props)    (gnus-add-text-properties-when 'article-type nil b e props)
# Line 1080  Initialized from `text-mode-syntax-table Line 1496  Initialized from `text-mode-syntax-table
1496    
1497  (defun gnus-article-hide-text-type (b e type)  (defun gnus-article-hide-text-type (b e type)
1498    "Hide text of TYPE between B and E."    "Hide text of TYPE between B and E."
1499    (push type gnus-article-wash-types)    (gnus-add-wash-type type)
1500    (gnus-article-hide-text    (gnus-article-hide-text
1501     b e (cons 'article-type (cons type gnus-hidden-properties))))     b e (cons 'article-type (cons type gnus-hidden-properties))))
1502    
1503  (defun gnus-article-unhide-text-type (b e type)  (defun gnus-article-unhide-text-type (b e type)
1504    "Unhide text of TYPE between B and E."    "Unhide text of TYPE between B and E."
1505    (setq gnus-article-wash-types    (gnus-delete-wash-type type)
         (delq type gnus-article-wash-types))  
1506    (remove-text-properties    (remove-text-properties
1507     b e (cons 'article-type (cons type gnus-hidden-properties)))     b e (cons 'article-type (cons type gnus-hidden-properties)))
1508    (when (memq 'intangible gnus-hidden-properties)    (when (memq 'intangible gnus-hidden-properties)
# Line 1127  Initialized from `text-mode-syntax-table Line 1542  Initialized from `text-mode-syntax-table
1542  (defsubst gnus-article-header-rank ()  (defsubst gnus-article-header-rank ()
1543    "Give the rank of the string HEADER as given by `gnus-sorted-header-list'."    "Give the rank of the string HEADER as given by `gnus-sorted-header-list'."
1544    (let ((list gnus-sorted-header-list)    (let ((list gnus-sorted-header-list)
1545          (i 0))          (i 1))
1546      (while list      (while list
1547        (when (looking-at (car list))        (if (looking-at (car list))
1548          (setq list nil))            (setq list nil)
1549        (setq list (cdr list))          (setq list (cdr list))
1550        (incf i))          (incf i)))
1551      i))        i))
1552    
1553  (defun article-hide-headers (&optional arg delete)  (defun article-hide-headers (&optional arg delete)
1554    "Hide unwanted headers and possibly sort them as well."    "Hide unwanted headers and possibly sort them as well."
1555    (interactive)    (interactive)
1556    ;; This function might be inhibited.    ;; This function might be inhibited.
1557    (unless gnus-inhibit-hiding    (unless gnus-inhibit-hiding
1558      (save-excursion      (let ((inhibit-read-only nil)
1559        (save-restriction            (case-fold-search t)
1560          (let ((inhibit-read-only t)            (max (1+ (length gnus-sorted-header-list)))
1561                (case-fold-search t)            (inhibit-point-motion-hooks t)
1562                (max (1+ (length gnus-sorted-header-list)))            (cur (current-buffer))
1563                (ignored (when (not gnus-visible-headers)            ignored visible beg)
1564                           (cond ((stringp gnus-ignored-headers)        (save-excursion
1565                                  gnus-ignored-headers)          ;; `gnus-ignored-headers' and `gnus-visible-headers' may be
1566                                 ((listp gnus-ignored-headers)          ;; group parameters, so we should go to the summary buffer.
1567                                  (mapconcat 'identity gnus-ignored-headers          (when (prog1
1568                                             "\\|")))))                    (condition-case nil
1569                (visible                        (progn (set-buffer gnus-summary-buffer) t)
1570                 (cond ((stringp gnus-visible-headers)                      (error nil))
1571                        gnus-visible-headers)                  (setq ignored (when (not gnus-visible-headers)
1572                       ((and gnus-visible-headers                                  (cond ((stringp gnus-ignored-headers)
1573                             (listp gnus-visible-headers))                                         gnus-ignored-headers)
1574                        (mapconcat 'identity gnus-visible-headers "\\|"))))                                        ((listp gnus-ignored-headers)
1575                (inhibit-point-motion-hooks t)                                         (mapconcat 'identity
1576                beg)                                                    gnus-ignored-headers
1577                                                      "\\|"))))
1578                          visible (cond ((stringp gnus-visible-headers)
1579                                         gnus-visible-headers)
1580                                        ((and gnus-visible-headers
1581                                              (listp gnus-visible-headers))
1582                                         (mapconcat 'identity
1583                                                    gnus-visible-headers
1584                                                    "\\|")))))
1585              (set-buffer cur))
1586            (save-restriction
1587            ;; First we narrow to just the headers.            ;; First we narrow to just the headers.
1588            (article-narrow-to-head)            (article-narrow-to-head)
1589            ;; Hide any "From " lines at the beginning of (mail) articles.            ;; Hide any "From " lines at the beginning of (mail) articles.
# Line 1171  Initialized from `text-mode-syntax-table Line 1596  Initialized from `text-mode-syntax-table
1596            ;; `gnus-ignored-headers' and `gnus-visible-headers' to            ;; `gnus-ignored-headers' and `gnus-visible-headers' to
1597            ;; select which header lines is to remain visible in the            ;; select which header lines is to remain visible in the
1598            ;; article buffer.            ;; article buffer.
1599            (while (re-search-forward "^[^ \t]*:" nil t)            (while (re-search-forward "^[^ \t:]*:" nil t)
1600              (beginning-of-line)              (beginning-of-line)
1601              ;; Mark the rank of the header.              ;; Mark the rank of the header.
1602              (put-text-property              (put-text-property
# Line 1186  Initialized from `text-mode-syntax-table Line 1611  Initialized from `text-mode-syntax-table
1611            (when (setq beg (text-property-any            (when (setq beg (text-property-any
1612                             (point-min) (point-max) 'message-rank (+ 2 max)))                             (point-min) (point-max) 'message-rank (+ 2 max)))
1613              ;; We delete the unwanted headers.              ;; We delete the unwanted headers.
1614              (push 'headers gnus-article-wash-types)              (gnus-add-wash-type 'headers)
1615              (add-text-properties (point-min) (+ 5 (point-min))              (add-text-properties (point-min) (+ 5 (point-min))
1616                                   '(article-type headers dummy-invisible t))                                   '(article-type headers dummy-invisible t))
1617              (delete-region beg (point-max))))))))              (delete-region beg (point-max))))))))
# Line 1214  always hide." Line 1639  always hide."
1639                (while (re-search-forward "^[^: \t]+:[ \t]*\n[^ \t]" nil t)                (while (re-search-forward "^[^: \t]+:[ \t]*\n[^ \t]" nil t)
1640                  (forward-line -1)                  (forward-line -1)
1641                  (gnus-article-hide-text-type                  (gnus-article-hide-text-type
1642                   (progn (beginning-of-line) (point))                   (gnus-point-at-bol)
1643                   (progn                   (progn
1644                     (end-of-line)                     (end-of-line)
1645                     (if (re-search-forward "^[^ \t]" nil t)                     (if (re-search-forward "^[^ \t]" nil t)
# Line 1223  always hide." Line 1648  always hide."
1648                   'boring-headers)))                   'boring-headers)))
1649               ;; Hide boring Newsgroups header.               ;; Hide boring Newsgroups header.
1650               ((eq elem 'newsgroups)               ((eq elem 'newsgroups)
1651                (when (equal (gnus-fetch-field "newsgroups")                (when (gnus-string-equal
1652                             (gnus-group-real-name                       (gnus-fetch-field "newsgroups")
1653                              (if (boundp 'gnus-newsgroup-name)                       (gnus-group-real-name
1654                                  gnus-newsgroup-name                        (if (boundp 'gnus-newsgroup-name)
1655                                "")))                            gnus-newsgroup-name
1656                            "")))
1657                  (gnus-article-hide-header "newsgroups")))                  (gnus-article-hide-header "newsgroups")))
1658                 ((eq elem 'to-address)
1659                  (let ((to (message-fetch-field "to"))
1660                        (to-address
1661                         (gnus-parameter-to-address
1662                          (if (boundp 'gnus-newsgroup-name)
1663                              gnus-newsgroup-name ""))))
1664                    (when (and to to-address
1665                               (ignore-errors
1666                                 (gnus-string-equal
1667                                  ;; only one address in To
1668                                  (nth 1 (mail-extract-address-components to))
1669                                  to-address)))
1670                      (gnus-article-hide-header "to"))))
1671                 ((eq elem 'to-list)
1672                  (let ((to (message-fetch-field "to"))
1673                        (to-list
1674                         (gnus-parameter-to-list
1675                          (if (boundp 'gnus-newsgroup-name)
1676                              gnus-newsgroup-name ""))))
1677                    (when (and to to-list
1678                               (ignore-errors
1679                                 (gnus-string-equal
1680                                  ;; only one address in To
1681                                  (nth 1 (mail-extract-address-components to))
1682                                  to-list)))
1683                      (gnus-article-hide-header "to"))))
1684                 ((eq elem 'cc-list)
1685                  (let ((cc (message-fetch-field "cc"))
1686                        (to-list
1687                         (gnus-parameter-to-list
1688                          (if (boundp 'gnus-newsgroup-name)
1689                              gnus-newsgroup-name ""))))
1690                    (when (and cc to-list
1691                               (ignore-errors
1692                                 (gnus-string-equal
1693                                  ;; only one address in CC
1694                                  (nth 1 (mail-extract-address-components cc))
1695                                  to-list)))
1696                      (gnus-article-hide-header "cc"))))
1697               ((eq elem 'followup-to)               ((eq elem 'followup-to)
1698                (when (equal (message-fetch-field "followup-to")                (when (gnus-string-equal
1699                             (message-fetch-field "newsgroups"))                       (message-fetch-field "followup-to")
1700                         (message-fetch-field "newsgroups"))
1701                  (gnus-article-hide-header "followup-to")))                  (gnus-article-hide-header "followup-to")))
1702               ((eq elem 'reply-to)               ((eq elem 'reply-to)
1703                (let ((from (message-fetch-field "from"))                (if (gnus-group-find-parameter
1704                      (reply-to (message-fetch-field "reply-to")))                     gnus-newsgroup-name 'broken-reply-to)
1705                  (when (and                    (gnus-article-hide-header "reply-to")
1706                    (let ((from (message-fetch-field "from"))
1707                          (reply-to (message-fetch-field "reply-to")))
1708                      (when
1709                          (and
1710                         from reply-to                         from reply-to
1711                         (ignore-errors                         (ignore-errors
1712                           (equal                           (equal
1713                            (nth 1 (mail-extract-address-components from))                            (sort (mapcar
1714                            (nth 1 (mail-extract-address-components reply-to)))))                                   (lambda (x) (downcase (cadr x)))
1715                    (gnus-article-hide-header "reply-to"))))                                   (mail-extract-address-components from t))
1716                                    'string<)
1717                              (sort (mapcar
1718                                     (lambda (x) (downcase (cadr x)))
1719                                     (mail-extract-address-components reply-to t))
1720                                    'string<))))
1721                        (gnus-article-hide-header "reply-to")))))
1722               ((eq elem 'date)               ((eq elem 'date)
1723                (let ((date (message-fetch-field "date")))                (let ((date (message-fetch-field "date")))
1724                  (when (and date                  (when (and date
# Line 1289  always hide." Line 1765  always hide."
1765      (goto-char (point-min))      (goto-char (point-min))
1766      (when (re-search-forward (concat "^" header ":") nil t)      (when (re-search-forward (concat "^" header ":") nil t)
1767        (gnus-article-hide-text-type        (gnus-article-hide-text-type
1768         (progn (beginning-of-line) (point))         (gnus-point-at-bol)
1769         (progn         (progn
1770           (end-of-line)           (end-of-line)
1771           (if (re-search-forward "^[^ \t]" nil t)           (if (re-search-forward "^[^ \t]" nil t)
# Line 1329  always hide." Line 1805  always hide."
1805            (forward-line 1))))))            (forward-line 1))))))
1806    
1807  (defun article-treat-dumbquotes ()  (defun article-treat-dumbquotes ()
1808    "Translate M****s*** sm*rtq**t*s into proper text.    "Translate M****s*** sm*rtq**t*s and other symbols into proper text.
1809  Note that this function guesses whether a character is a sm*rtq**t* or  Note that this function guesses whether a character is a sm*rtq**t* or
1810  not, so it should only be used interactively.  not, so it should only be used interactively.
1811    
1812  Sm*rtq**t*s are M****s***'s unilateral extension to the character map  Sm*rtq**t*s are M****s***'s unilateral extension to the
1813  in an attempt to provide more quoting characters.  If you see  iso-8859-1 character map in an attempt to provide more quoting
1814  something like \\222 or \\264 where you're expecting some kind of  characters.  If you see something like \\222 or \\264 where
1815  apostrophe or quotation mark, then try this wash."  you're expecting some kind of apostrophe or quotation mark, then
1816    try this wash."
1817    (interactive)    (interactive)
1818    (article-translate-strings gnus-article-dumbquotes-map))    (article-translate-strings gnus-article-dumbquotes-map))
1819    
# Line 1395  MAP is an alist where the elements are o Line 1872  MAP is an alist where the elements are o
1872                (put-text-property                (put-text-property
1873                 (point) (1+ (point)) 'face 'underline)))))))))                 (point) (1+ (point)) 'face 'underline)))))))))
1874    
1875    (defun gnus-article-treat-unfold-headers ()
1876      "Unfold folded message headers.
1877    Only the headers that fit into the current window width will be
1878    unfolded."
1879      (interactive)
1880      (gnus-with-article-headers
1881        (let (length)
1882          (while (not (eobp))
1883            (save-restriction
1884              (mail-header-narrow-to-field)
1885              (let ((header (buffer-string)))
1886                (with-temp-buffer
1887                  (insert header)
1888                  (goto-char (point-min))
1889                  (while (re-search-forward "\n[\t ]" nil t)
1890                    (replace-match " " t t)))
1891                (setq length (- (point-max) (point-min) 1)))
1892              (when (< length (window-width))
1893                (while (re-search-forward "\n[\t ]" nil t)
1894                  (replace-match " " t t)))
1895              (goto-char (point-max)))))))
1896    
1897    (defun gnus-article-treat-fold-headers ()
1898      "Fold message headers."
1899      (interactive)
1900      (gnus-with-article-headers
1901        (while (not (eobp))
1902          (save-restriction
1903            (mail-header-narrow-to-field)
1904            (mail-header-fold-field)
1905            (goto-char (point-max))))))
1906    
1907    (defun gnus-treat-smiley ()
1908      "Toggle display of textual emoticons (\"smileys\") as small graphical icons."
1909      (interactive)
1910      (gnus-with-article-buffer
1911        (if (memq 'smiley gnus-article-wash-types)
1912            (gnus-delete-images 'smiley)
1913          (article-goto-body)
1914          (let ((images (smiley-region (point) (point-max))))
1915            (when images
1916              (gnus-add-wash-type 'smiley)
1917              (dolist (image images)
1918                (gnus-add-image 'smiley image)))))))
1919    
1920    (defun gnus-article-remove-images ()
1921      "Remove all images from the article buffer."
1922      (interactive)
1923      (gnus-with-article-buffer
1924        (dolist (elem gnus-article-image-alist)
1925          (gnus-delete-images (car elem)))))
1926    
1927    (defun gnus-article-treat-fold-newsgroups ()
1928      "Unfold folded message headers.
1929    Only the headers that fit into the current window width will be
1930    unfolded."
1931      (interactive)
1932      (gnus-with-article-headers
1933        (while (gnus-article-goto-header "newsgroups\\|followup-to")
1934          (save-restriction
1935            (mail-header-narrow-to-field)
1936            (while (re-search-forward ", *" nil t)
1937              (replace-match ", " t t))
1938            (mail-header-fold-field)
1939            (goto-char (point-max))))))
1940    
1941    (defun gnus-article-treat-body-boundary ()
1942      "Place a boundary line at the end of the headers."
1943      (interactive)
1944      (when (and gnus-body-boundary-delimiter
1945                 (> (length gnus-body-boundary-delimiter) 0))
1946        (gnus-with-article-headers
1947          (goto-char (point-max))
1948          (let ((start (point)))
1949            (insert "X-Boundary: ")
1950            (gnus-add-text-properties start (point) '(invisible t intangible t))
1951            (insert (let (str)
1952                      (while (>= (1- (window-width)) (length str))
1953                        (setq str (concat str gnus-body-boundary-delimiter)))
1954                      (substring str 0 (1- (window-width))))
1955                    "\n")
1956            (gnus-put-text-property start (point) 'gnus-decoration 'header)))))
1957    
1958  (defun article-fill-long-lines ()  (defun article-fill-long-lines ()
1959    "Fill lines that are wider than the window width."    "Fill lines that are wider than the window width."
1960    (interactive)    (interactive)
# Line 1407  MAP is an alist where the elements are o Line 1967  MAP is an alist where the elements are o
1967            (while (not (eobp))            (while (not (eobp))
1968              (end-of-line)              (end-of-line)
1969              (when (>= (current-column) (min fill-column width))              (when (>= (current-column) (min fill-column width))
1970                (narrow-to-region (point) (gnus-point-at-bol))                (narrow-to-region (min (1+ (point)) (point-max))
1971                (fill-paragraph nil)                                  (gnus-point-at-bol))
1972                (goto-char (point-max))                (let ((goback (point-marker)))
1973                    (fill-paragraph nil)
1974                    (goto-char (marker-position goback)))
1975                (widen))                (widen))
1976              (forward-line 1)))))))              (forward-line 1)))))))
1977    
# Line 1453  MAP is an alist where the elements are o Line 2015  MAP is an alist where the elements are o
2015           (forward-line 1)           (forward-line 1)
2016           (point))))))           (point))))))
2017    
2018    (defun article-display-face ()
2019      "Display any Face headers in the header."
2020      (interactive)
2021      (let ((wash-face-p buffer-read-only))
2022        (gnus-with-article-headers
2023          ;; When displaying parts, this function can be called several times on
2024          ;; the same article, without any intended toggle semantic (as typing `W
2025          ;; D d' would have). So face deletion must occur only when we come from
2026          ;; an interactive command, that is when the *Article* buffer is
2027          ;; read-only.
2028          (if (and wash-face-p (memq 'face gnus-article-wash-types))
2029              (gnus-delete-images 'face)
2030            (let (face faces)
2031              (save-excursion
2032                (when (and wash-face-p
2033                           (progn
2034                             (goto-char (point-min))
2035                             (not (re-search-forward "^Face:[\t ]*" nil t)))
2036                           (gnus-buffer-live-p gnus-original-article-buffer))
2037                  (set-buffer gnus-original-article-buffer))
2038                (save-restriction
2039                  (mail-narrow-to-head)
2040                  (while (gnus-article-goto-header "Face")
2041                    (push (mail-header-field-value) faces))))
2042              (while (setq face (pop faces))
2043                (let ((png (gnus-convert-face-to-png face))
2044                      image)
2045                  (when png
2046                    (setq image (gnus-create-image png 'png t))
2047                    (gnus-article-goto-header "from")
2048                    (when (bobp)
2049                      (insert "From: [no `from' set]\n")
2050                      (forward-char -17))
2051                    (gnus-add-wash-type 'face)
2052                    (gnus-add-image 'face image)
2053                    (gnus-put-image image nil 'face))))))
2054          )))
2055    
2056  (defun article-display-x-face (&optional force)  (defun article-display-x-face (&optional force)
2057    "Look for an X-Face header and display it if present."    "Look for an X-Face header and display it if present."
2058    (interactive (list 'force))    (interactive (list 'force))
2059    (save-excursion    (let ((wash-face-p buffer-read-only)) ;; When type `W f'
2060      ;; Delete the old process, if any.      (gnus-with-article-headers
2061      (when (process-status "article-x-face")        ;; Delete the old process, if any.
2062        (delete-process "article-x-face"))        (when (process-status "article-x-face")
2063      (let ((inhibit-point-motion-hooks t)          (delete-process "article-x-face"))
2064            (case-fold-search t)        ;; See the comment in `article-display-face'.
2065            from last)        (if (and wash-face-p (memq 'xface gnus-article-wash-types))
2066        (save-restriction            ;; We have already displayed X-Faces, so we remove them
2067          (article-narrow-to-head)            ;; instead.
2068          (goto-char (point-min))            (gnus-delete-images 'xface)
2069          (setq from (message-fetch-field "from"))          ;; Display X-Faces.
2070          (goto-char (point-min))          (let (x-faces from face)
         (while (and gnus-article-x-face-command  
                     (not last)  
                     (or force  
                         ;; Check whether this face is censored.  
                         (not gnus-article-x-face-too-ugly)  
                         (and gnus-article-x-face-too-ugly from  
                              (not (string-match gnus-article-x-face-too-ugly  
                                                 from))))  
                     ;; Has to be present.  
                     (re-search-forward "^X-Face: " nil t))  
           ;; This used to try to do multiple faces (`while' instead of  
           ;; `when' above), but (a) sending multiple EOFs to xv doesn't  
           ;; work (b) it can crash some versions of Emacs (c) are  
           ;; multiple faces really something to encourage?  
           (when (stringp gnus-article-x-face-command)  
             (setq last t))  
           ;; We now have the area of the buffer where the X-Face is stored.  
2071            (save-excursion            (save-excursion
2072              (let ((beg (point))              (when (and wash-face-p
2073                    (end (1- (re-search-forward "^\\($\\|[^ \t]\\)" nil t))))                         (progn
2074                ;; We display the face.                           (goto-char (point-min))
2075                (if (symbolp gnus-article-x-face-command)                           (not (re-search-forward
2076                    ;; The command is a lisp function, so we call it.                                 "^X-Face\\(-[0-9]+\\)?:[\t ]*" nil t)))
2077                    (if (gnus-functionp gnus-article-x-face-command)                         (gnus-buffer-live-p gnus-original-article-buffer))
2078                        (funcall gnus-article-x-face-command beg end)                ;; If type `W f', use gnus-original-article-buffer,
2079                      (error "%s is not a function" gnus-article-x-face-command))                ;; otherwise use the current buffer because displaying
2080                  ;; The command is a string, so we interpret the command                ;; RFC822 parts calls this function too.
2081                  ;; as a, well, command, and fork it off.                (set-buffer gnus-original-article-buffer))
2082                  (let ((process-connection-type nil))              (save-restriction
2083                    (process-kill-without-query                (mail-narrow-to-head)
2084                     (start-process                (while (gnus-article-goto-header "X-Face")
2085                      "article-x-face" nil shell-file-name shell-command-switch                  (push (mail-header-field-value) x-faces))
2086                      gnus-article-x-face-command))                (setq from (message-fetch-field "from"))))
2087                    (process-send-region "article-x-face" beg end)            ;; Sending multiple EOFs to xv doesn't work, so we only do a
2088                    (process-send-eof "article-x-face"))))))))))            ;; single external face.
2089              (when (stringp gnus-article-x-face-command)
2090                (setq x-faces (list (car x-faces))))
2091              (while (and (setq face (pop x-faces))
2092                          gnus-article-x-face-command
2093                          (or force
2094                              ;; Check whether this face is censored.
2095                              (not gnus-article-x-face-too-ugly)
2096                              (and gnus-article-x-face-too-ugly from
2097                                   (not (string-match gnus-article-x-face-too-ugly
2098                                                      from)))))
2099                ;; We display the face.
2100                (cond ((stringp gnus-article-x-face-command)
2101                       ;; The command is a string, so we interpret the command
2102                       ;; as a, well, command, and fork it off.
2103                       (let ((process-connection-type nil))
2104                         (process-kill-without-query
2105                          (start-process
2106                           "article-x-face" nil shell-file-name
2107                           shell-command-switch gnus-article-x-face-command))
2108                         (with-temp-buffer
2109                           (insert face)
2110                           (process-send-region "article-x-face"
2111                                                (point-min) (point-max)))
2112                         (process-send-eof "article-x-face")))
2113                      ((functionp gnus-article-x-face-command)
2114                       ;; The command is a lisp function, so we call it.
2115                       (funcall gnus-article-x-face-command face))
2116                      (t
2117                       (error "%s is not a function"
2118                              gnus-article-x-face-command)))))))))
2119    
2120  (defun article-decode-mime-words ()  (defun article-decode-mime-words ()
2121    "Decode all MIME-encoded words in the article."    "Decode all MIME-encoded words in the article."
# Line 1510  MAP is an alist where the elements are o Line 2123  MAP is an alist where the elements are o
2123    (save-excursion    (save-excursion
2124      (set-buffer gnus-article-buffer)      (set-buffer gnus-article-buffer)
2125      (let ((inhibit-point-motion-hooks t)      (let ((inhibit-point-motion-hooks t)
2126            buffer-read-only            (inhibit-read-only t)
2127            (mail-parse-charset gnus-newsgroup-charset)            (mail-parse-charset gnus-newsgroup-charset)
2128            (mail-parse-ignored-charsets            (mail-parse-ignored-charsets
2129             (save-excursion (set-buffer gnus-summary-buffer)             (save-excursion (set-buffer gnus-summary-buffer)
# Line 1522  MAP is an alist where the elements are o Line 2135  MAP is an alist where the elements are o
2135  If PROMPT (the prefix), prompt for a coding system to use."  If PROMPT (the prefix), prompt for a coding system to use."
2136    (interactive "P")    (interactive "P")
2137    (let ((inhibit-point-motion-hooks t) (case-fold-search t)    (let ((inhibit-point-motion-hooks t) (case-fold-search t)
2138          buffer-read-only          (inhibit-read-only t)
2139          (mail-parse-charset gnus-newsgroup-charset)          (mail-parse-charset gnus-newsgroup-charset)
2140          (mail-parse-ignored-charsets          (mail-parse-ignored-charsets
2141           (save-excursion (condition-case nil           (save-excursion (condition-case nil
# Line 1572  If PROMPT (the prefix), prompt for a cod Line 2185  If PROMPT (the prefix), prompt for a cod
2185                               (set-buffer gnus-summary-buffer)                               (set-buffer gnus-summary-buffer)
2186                             (error))                             (error))
2187                           gnus-newsgroup-ignored-charsets))                           gnus-newsgroup-ignored-charsets))
2188          buffer-read-only)          (inhibit-read-only t))
2189      (save-restriction      (save-restriction
2190        (article-narrow-to-head)        (article-narrow-to-head)
2191        (funcall gnus-decode-header-function (point-min) (point-max)))))        (funcall gnus-decode-header-function (point-min) (point-max)))))
2192    
2193  (defun article-de-quoted-unreadable (&optional force)  (defun article-decode-group-name ()
2194      "Decode group names in `Newsgroups:'."
2195      (let ((inhibit-point-motion-hooks t)
2196            (inhibit-read-only t)
2197            (method (gnus-find-method-for-group gnus-newsgroup-name)))
2198        (when (and (or gnus-group-name-charset-method-alist
2199                       gnus-group-name-charset-group-alist)
2200                   (gnus-buffer-live-p gnus-original-article-buffer))
2201          (save-restriction
2202            (article-narrow-to-head)
2203            (with-current-buffer gnus-original-article-buffer
2204              (goto-char (point-min)))
2205            (while (re-search-forward
2206                    "^Newsgroups:\\(\\(.\\|\n[\t ]\\)*\\)\n[^\t ]" nil t)
2207              (replace-match (save-match-data
2208                               (gnus-decode-newsgroups
2209                                ;; XXX how to use data in article buffer?
2210                                (with-current-buffer gnus-original-article-buffer
2211                                  (re-search-forward
2212                                   "^Newsgroups:\\(\\(.\\|\n[\t ]\\)*\\)\n[^\t ]"
2213                                   nil t)
2214                                  (match-string 1))
2215                                gnus-newsgroup-name method))
2216                             t t nil 1))
2217            (goto-char (point-min))
2218            (with-current-buffer gnus-original-article-buffer
2219              (goto-char (point-min)))
2220            (while (re-search-forward
2221                    "^Followup-To:\\(\\(.\\|\n[\t ]\\)*\\)\n[^\t ]" nil t)
2222              (replace-match (save-match-data
2223                               (gnus-decode-newsgroups
2224                                ;; XXX how to use data in article buffer?
2225                                (with-current-buffer gnus-original-article-buffer
2226                                  (re-search-forward
2227                                   "^Followup-To:\\(\\(.\\|\n[\t ]\\)*\\)\n[^\t ]"
2228                                   nil t)
2229                                  (match-string 1))
2230                                gnus-newsgroup-name method))
2231                             t t nil 1))))))
2232    
2233    (autoload 'idna-to-unicode "idna")
2234    
2235    (defun article-decode-idna-rhs ()
2236      "Decode IDNA strings in RHS in From:, To: and Cc: headers in current buffer."
2237      (when gnus-use-idna
2238        (save-restriction
2239          (let ((inhibit-point-motion-hooks t)
2240                (inhibit-read-only t))
2241            (article-narrow-to-head)
2242            (goto-char (point-min))
2243            (while (re-search-forward "@.*\\(xn--[-A-Za-z0-9.]*\\)[ \t\n\r,>]" nil t)
2244              (let (ace unicode)
2245                (when (save-match-data
2246                        (and (setq ace (match-string 1))
2247                             (save-excursion
2248                               (and (re-search-backward "^[^ \t]" nil t)
2249                                    (looking-at "From\\|To\\|Cc")))
2250                             (setq unicode (idna-to-unicode ace))))
2251                  (unless (string= ace unicode)
2252                    (replace-match unicode nil nil nil 1)))))))))
2253    
2254    (defun article-de-quoted-unreadable (&optional force read-charset)
2255    "Translate a quoted-printable-encoded article.    "Translate a quoted-printable-encoded article.
2256  If FORCE, decode the article whether it is marked as quoted-printable  If FORCE, decode the article whether it is marked as quoted-printable
2257  or not."  or not.
2258    (interactive (list 'force))  If READ-CHARSET, ask for a coding system."
2259      (interactive (list 'force current-prefix-arg))
2260    (save-excursion    (save-excursion
2261      (let ((inhibit-read-only t) type charset)      (let ((inhibit-read-only t) type charset)
2262        (if (gnus-buffer-live-p gnus-original-article-buffer)        (if (gnus-buffer-live-p gnus-original-article-buffer)
# Line 1596  or not." Line 2271  or not."
2271                                   (mail-content-type-get ctl 'charset)))                                   (mail-content-type-get ctl 'charset)))
2272                (if (stringp charset)                (if (stringp charset)
2273                    (setq charset (intern (downcase charset)))))))                    (setq charset (intern (downcase charset)))))))
2274          (if read-charset
2275              (setq charset (mm-read-coding-system "Charset: " charset)))
2276        (unless charset        (unless charset
2277          (setq charset gnus-newsgroup-charset))          (setq charset gnus-newsgroup-charset))
2278        (when (or force        (when (or force
# Line 1605  or not." Line 2282  or not."
2282          (quoted-printable-decode-region          (quoted-printable-decode-region
2283           (point) (point-max) (mm-charset-to-coding-system charset))))))           (point) (point-max) (mm-charset-to-coding-system charset))))))
2284    
2285  (defun article-de-base64-unreadable (&optional force)  (defun article-de-base64-unreadable (&optional force read-charset)
2286    "Translate a base64 article.    "Translate a base64 article.
2287  If FORCE, decode the article whether it is marked as base64 not."  If FORCE, decode the article whether it is marked as base64 not.
2288    (interactive (list 'force))  If READ-CHARSET, ask for a coding system."
2289      (interactive (list 'force current-prefix-arg))
2290    (save-excursion    (save-excursion
2291      (let ((inhibit-read-only t) type charset)      (let ((inhibit-read-only t) type charset)
2292        (if (gnus-buffer-live-p gnus-original-article-buffer)        (if (gnus-buffer-live-p gnus-original-article-buffer)
# Line 1623  If FORCE, decode the article whether it Line 2301  If FORCE, decode the article whether it
2301                                   (mail-content-type-get ctl 'charset)))                                   (mail-content-type-get ctl 'charset)))
2302                (if (stringp charset)                (if (stringp charset)
2303                    (setq charset (intern (downcase charset)))))))                    (setq charset (intern (downcase charset)))))))
2304          (if read-charset
2305              (setq charset (mm-read-coding-system "Charset: " charset)))
2306        (unless charset        (unless charset
2307          (setq charset gnus-newsgroup-charset))          (setq charset gnus-newsgroup-charset))
2308        (when (or force        (when (or force
# Line 1646  If FORCE, decode the article whether it Line 2326  If FORCE, decode the article whether it
2326      (let ((inhibit-read-only t))      (let ((inhibit-read-only t))
2327        (rfc1843-decode-region (point-min) (point-max)))))        (rfc1843-decode-region (point-min) (point-max)))))
2328    
2329  (defun article-wash-html ()  (defun article-unsplit-urls ()
2330    "Format an html article."    "Remove the newlines that some other mailers insert into URLs."
2331    (interactive)    (interactive)
2332    (save-excursion    (save-excursion
2333        (let ((inhibit-read-only t))
2334          (goto-char (point-min))
2335          (while (re-search-forward
2336                  "^\\(\\(https?\\|ftp\\)://\\S-+\\) *\n\\(\\S-+\\)" nil t)
2337            (replace-match "\\1\\3" t)))
2338        (when (interactive-p)
2339          (gnus-treat-article nil))))
2340    
2341    
2342    (defun article-wash-html (&optional read-charset)
2343      "Format an HTML article.
2344    If READ-CHARSET, ask for a coding system."
2345      (interactive "P")
2346      (save-excursion
2347      (let ((inhibit-read-only t)      (let ((inhibit-read-only t)
2348            charset)            charset)
2349        (if (gnus-buffer-live-p gnus-original-article-buffer)        (when (gnus-buffer-live-p gnus-original-article-buffer)
2350            (with-current-buffer gnus-original-article-buffer          (with-current-buffer gnus-original-article-buffer
2351              (let* ((ct (gnus-fetch-field "content-type"))            (let* ((ct (gnus-fetch-field "content-type"))
2352                     (ctl (and ct                   (ctl (and ct
2353                               (ignore-errors                             (ignore-errors
2354                                 (mail-header-parse-content-type ct)))))                               (mail-header-parse-content-type ct)))))
2355                (setq charset (and ctl              (setq charset (and ctl
2356                                   (mail-content-type-get ctl 'charset)))                                 (mail-content-type-get ctl 'charset)))
2357                (if (stringp charset)              (when (stringp charset)
2358                    (setq charset (intern (downcase charset)))))))                (setq charset (intern (downcase charset)))))))
2359          (when read-charset
2360            (setq charset (mm-read-coding-system "Charset: " charset)))
2361        (unless charset        (unless charset
2362          (setq charset gnus-newsgroup-charset))          (setq charset gnus-newsgroup-charset))
2363        (article-goto-body)        (article-goto-body)
2364        (save-window-excursion        (save-window-excursion
2365          (save-restriction          (save-restriction
2366            (narrow-to-region (point) (point-max))            (narrow-to-region (point) (point-max))
2367            (mm-setup-w3)            (let* ((func (or gnus-article-wash-function mm-text-html-renderer))
2368            (let ((w3-strict-width (window-width))                   (entry (assq func mm-text-html-washer-alist)))
2369                  (url-gateway-unplugged t)              (when entry
2370                  (url-standalone-mode t))                (setq func (cdr entry)))
2371              (condition-case var              (cond
2372                  (w3-region (point-min) (point-max))               ((functionp func)
2373                (error))))))))                (funcall func))
2374                 (t
2375                  (apply (car func) (cdr func))))))))))
2376    
2377    (defun gnus-article-wash-html-with-w3 ()
2378      "Wash the current buffer with w3."
2379      (mm-setup-w3)
2380      (let ((w3-strict-width (window-width))
2381            (url-standalone-mode t)
2382            (url-gateway-unplugged t)
2383            (w3-honor-stylesheets nil))
2384        (condition-case ()
2385            (w3-region (point-min) (point-max))
2386          (error))))
2387    
2388    (defun gnus-article-wash-html-with-w3m ()
2389      "Wash the current buffer with emacs-w3m."
2390      (mm-setup-w3m)
2391      (save-restriction
2392        (narrow-to-region (point) (point-max))
2393        (let ((w3m-safe-url-regexp mm-w3m-safe-url-regexp)
2394              w3m-force-redisplay)
2395          (w3m-region (point-min) (point-max)))
2396        (when (and mm-inline-text-html-with-w3m-keymap
2397                   (boundp 'w3m-minor-mode-map)
2398                   w3m-minor-mode-map)
2399          (add-text-properties
2400           (point-min) (point-max)
2401           (list 'keymap w3m-minor-mode-map
2402                 ;; Put the mark meaning this part was rendered by emacs-w3m.
2403                 'mm-inline-text-html-with-w3m t)))))
2404    
2405  (defun article-hide-list-identifiers ()  (defun article-hide-list-identifiers ()
2406    "Remove list identifies from the Subject header.    "Remove list identifies from the Subject header.
2407  The `gnus-list-identifiers' variable specifies what to do."  The `gnus-list-identifiers' variable specifies what to do."
2408    (interactive)    (interactive)
2409    (save-excursion    (let ((inhibit-point-motion-hooks t)
2410      (save-restriction          (regexp (if (consp gnus-list-identifiers)
2411        (let ((inhibit-point-motion-hooks t)                      (mapconcat 'identity gnus-list-identifiers " *\\|")
2412              buffer-read-only)                    gnus-list-identifiers))
2413          (article-narrow-to-head)          (inhibit-read-only t))
2414          (let ((regexp (if (stringp gnus-list-identifiers) gnus-list-identifiers      (when regexp
2415                          (mapconcat 'identity gnus-list-identifiers " *\\|"))))        (save-excursion
2416            (when regexp          (save-restriction
2417              (goto-char (point-min))            (article-narrow-to-head)
2418              (when (re-search-forward            (goto-char (point-min))
2419                     (concat "^Subject: +\\(\\(\\(Re: +\\)?\\(" regexp            (while (re-search-forward
2420                             " *\\)\\)+\\(Re: +\\)?\\)")                    (concat "^Subject: +\\(R[Ee]: +\\)*\\(" regexp " *\\)")
2421                     nil t)                    nil t)
2422                (let ((s (or (match-string 3) (match-string 5))))              (delete-region (match-beginning 2) (match-end 0))
2423                  (delete-region (match-beginning 1) (match-end 1))              (beginning-of-line))
2424                  (when s            (when (re-search-forward
2425                    (goto-char (match-beginning 1))                   "^Subject: +\\(\\(R[Ee]: +\\)+\\)R[Ee]: +" nil t)
2426                    (insert s))))))))))              (delete-region (match-beginning 1) (match-end 1))))))))
   
 (defun article-hide-pgp ()  
   "Remove any PGP headers and signatures in the current article."  
   (interactive)  
   (save-excursion  
     (save-restriction  
       (let ((inhibit-point-motion-hooks t)  
             buffer-read-only beg end)  
         (article-goto-body)  
         ;; Hide the "header".  
         (when (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\n" nil t)  
           (push 'pgp gnus-article-wash-types)  
           (delete-region (match-beginning 0) (match-end 0))  
           ;; Remove armor headers (rfc2440 6.2)  
           (delete-region (point) (or (re-search-forward "^[ \t]*\n" nil t)  
                                      (point)))  
           (setq beg (point))  
           ;; Hide the actual signature.  
           (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t)  
                (setq end (1+ (match-beginning 0)))  
                (delete-region  
                 end  
                 (if (search-forward "\n-----END PGP SIGNATURE-----\n" nil t)  
                     (match-end 0)  
                   ;; Perhaps we shouldn't hide to the end of the buffer  
                   ;; if there is no end to the signature?  
                   (point-max))))  
           ;; Hide "- " PGP quotation markers.  
           (when (and beg end)  
             (narrow-to-region beg end)  
             (goto-char (point-min))  
             (while (re-search-forward "^- " nil t)  
               (delete-region  
                (match-beginning 0) (match-end 0)))  
             (widen))  
           (gnus-run-hooks 'gnus-article-hide-pgp-hook))))))  
2427    
2428  (defun article-hide-pem (&optional arg)  (defun article-hide-pem (&optional arg)
2429    "Toggle hiding of any PEM headers and signatures in the current article.    "Toggle hiding of any PEM headers and signatures in the current article.
# Line 1742  always hide." Line 2432  always hide."
2432    (interactive (gnus-article-hidden-arg))    (interactive (gnus-article-hidden-arg))
2433    (unless (gnus-article-check-hidden-text 'pem arg)    (unless (gnus-article-check-hidden-text 'pem arg)
2434      (save-excursion      (save-excursion
2435        (let (buffer-read-only end)        (let ((inhibit-read-only t) end)
2436          (goto-char (point-min))          (goto-char (point-min))
2437          ;; Hide the horrendously ugly "header".          ;; Hide the horrendously ugly "header".
2438          (when (and (search-forward          (when (and (search-forward
2439                      "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n"                      "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n"
2440                      nil t)                      nil t)
2441                     (setq end (1+ (match-beginning 0))))                     (setq end (1+ (match-beginning 0))))
2442            (push 'pem gnus-article-wash-types)            (gnus-add-wash-type 'pem)
2443            (gnus-article-hide-text-type            (gnus-article-hide-text-type
2444             end             end
2445             (if (search-forward "\n\n" nil t)             (if (search-forward "\n\n" nil t)
# Line 1763  always hide." Line 2453  always hide."
2453               (match-beginning 0) (match-end 0) 'pem)))))))               (match-beginning 0) (match-end 0) 'pem)))))))
2454    
2455  (defun article-strip-banner ()  (defun article-strip-banner ()
2456    "Strip the banner specified by the `banner' group parameter."    "Strip the banners specified by the `banner' group parameter and by
2457    `gnus-article-address-banner-alist'."
2458    (interactive)    (interactive)
2459    (save-excursion    (save-excursion
2460      (save-restriction      (save-restriction
2461          (let ((inhibit-point-motion-hooks t))
2462            (when (gnus-parameter-banner gnus-newsgroup-name)
2463              (article-really-strip-banner
2464               (gnus-parameter-banner gnus-newsgroup-name)))
2465            (when gnus-article-address-banner-alist
2466              (article-really-strip-banner
2467               (let ((from (save-restriction
2468                             (widen)
2469                             (article-narrow-to-head)
2470                             (mail-fetch-field "from"))))
2471                 (when (and from
2472                            (setq from
2473                                  (caar (mail-header-parse-addresses from))))
2474                   (catch 'found
2475                     (dolist (pair gnus-article-address-banner-alist)
2476                       (when (string-match (car pair) from)
2477                         (throw 'found (cdr pair)))))))))))))
2478    
2479    (defun article-really-strip-banner (banner)
2480      "Strip the banner specified by the argument."
2481      (save-excursion
2482        (save-restriction
2483        (let ((inhibit-point-motion-hooks t)        (let ((inhibit-point-motion-hooks t)
             (banner (gnus-group-find-parameter gnus-newsgroup-name 'banner))  
2484              (gnus-signature-limit nil)              (gnus-signature-limit nil)
2485              buffer-read-only beg end)              (inhibit-read-only t))
2486          (when banner          (article-goto-body)
2487            (article-goto-body)          (cond
2488            (cond           ((eq banner 'signature)
2489             ((eq banner 'signature)            (when (gnus-article-narrow-to-signature)
2490              (when (gnus-article-narrow-to-signature)              (widen)
2491                (widen)              (forward-line -1)
2492                (forward-line -1)              (delete-region (point) (point-max))))
2493                (delete-region (point) (point-max))))           ((symbolp banner)
2494             ((symbolp banner)            (if (setq banner (cdr (assq banner gnus-article-banner-alist)))
2495              (if (setq banner (cdr (assq banner gnus-article-banner-alist)))                (while (re-search-forward banner nil t)
2496                  (while (re-search-forward banner nil t)                  (delete-region (match-beginning 0) (match-end 0)))))
2497                    (delete-region (match-beginning 0) (match-end 0)))))           ((stringp banner)
2498             ((stringp banner)            (while (re-search-forward banner nil t)
2499              (while (re-search-forward banner nil t)              (delete-region (match-beginning 0) (match-end 0)))))))))
               (delete-region (match-beginning 0) (match-end 0))))))))))  
2500    
2501  (defun article-babel ()  (defun article-babel ()
2502    "Translate article using an online translation service."    "Translate article using an online translation service."
# Line 1798  always hide." Line 2509  always hide."
2509               (start (point))               (start (point))
2510               (end (point-max))               (end (point-max))
2511               (orig (buffer-substring start end))               (orig (buffer-substring start end))
2512               (trans (babel-as-string orig)))               (trans (babel-as-string orig)))
2513          (save-restriction          (save-restriction
2514            (narrow-to-region start end)            (narrow-to-region start end)
2515            (delete-region start end)            (delete-region start end)
2516            (insert trans))))))            (insert trans))))))
2517    
2518  (defun article-hide-signature (&optional arg)  (defun article-hide-signature (&optional arg)
2519    "Hide the signature in the current article.    "Hide the signature in the current article.
# Line 1815  always hide." Line 2526  always hide."
2526          (let ((inhibit-read-only t))          (let ((inhibit-read-only t))
2527            (when (gnus-article-narrow-to-signature)            (when (gnus-article-narrow-to-signature)
2528              (gnus-article-hide-text-type              (gnus-article-hide-text-type
2529               (point-min) (point-max) 'signature)))))))               (point-min) (point-max) 'signature))))))
2530      (gnus-set-mode-line 'article))
2531    
2532  (defun article-strip-headers-in-body ()  (defun article-strip-headers-in-body ()
2533    "Strip offensive headers from bodies."    "Strip offensive headers from bodies."
# Line 1831  always hide." Line 2543  always hide."
2543    (interactive)    (interactive)
2544    (save-excursion    (save-excursion
2545      (let ((inhibit-point-motion-hooks t)      (let ((inhibit-point-motion-hooks t)
2546            buffer-read-only)            (inhibit-read-only t))
2547        (when (article-goto-body)        (when (article-goto-body)
2548          (while (and (not (eobp))          (while (and (not (eobp))
2549                      (looking-at "[ \t]*$"))                      (looking-at "[ \t]*$"))
# Line 1866  Point is left at the beginning of the na Line 2578  Point is left at the beginning of the na
2578    (interactive)    (interactive)
2579    (save-excursion    (save-excursion
2580      (let ((inhibit-point-motion-hooks t)      (let ((inhibit-point-motion-hooks t)
2581            buffer-read-only)            (inhibit-read-only t))
2582        ;; First make all blank lines empty.        ;; First make all blank lines empty.
2583        (article-goto-body)        (article-goto-body)
2584        (while (re-search-forward "^[ \t]+$" nil t)        (while (re-search-forward "^[ \t]+$" nil t)
# Line 1875  Point is left at the beginning of the na Line 2587  Point is left at the beginning of the na
2587            (replace-match "" nil t)))            (replace-match "" nil t)))
2588        ;; Then replace multiple empty lines with a single empty line.        ;; Then replace multiple empty lines with a single empty line.
2589        (article-goto-body)        (article-goto-body)
2590        (while (re-search-forward "\n\n\n+" nil t)        (while (re-search-forward "\n\n\\(\n+\\)" nil t)
2591          (unless (gnus-annotation-in-region-p          (unless (gnus-annotation-in-region-p
2592                   (match-beginning 0) (match-end 0))                   (match-beginning 0) (match-end 0))
2593            (replace-match "\n\n" t t))))))            (delete-region (match-beginning 1) (match-end 1)))))))
2594    
2595  (defun article-strip-leading-space ()  (defun article-strip-leading-space ()
2596    "Remove all white space from the beginning of the lines in the article."    "Remove all white space from the beginning of the lines in the article."
2597    (interactive)    (interactive)
2598    (save-excursion    (save-excursion
2599      (let ((inhibit-point-motion-hooks t)      (let ((inhibit-point-motion-hooks t)
2600            buffer-read-only)            (inhibit-read-only t))
2601        (article-goto-body)        (article-goto-body)
2602        (while (re-search-forward "^[ \t]+" nil t)        (while (re-search-forward "^[ \t]+" nil t)
2603          (replace-match "" t t)))))          (replace-match "" t t)))))
# Line 1895  Point is left at the beginning of the na Line 2607  Point is left at the beginning of the na
2607    (interactive)    (interactive)
2608    (save-excursion    (save-excursion
2609      (let ((inhibit-point-motion-hooks t)      (let ((inhibit-point-motion-hooks t)
2610            buffer-read-only)            (inhibit-read-only t))
2611        (article-goto-body)        (article-goto-body)
2612        (while (re-search-forward "[ \t]+$" nil t)        (while (re-search-forward "[ \t]+$" nil t)
2613          (replace-match "" t t)))))          (replace-match "" t t)))))
# Line 1912  Point is left at the beginning of the na Line 2624  Point is left at the beginning of the na
2624    (interactive)    (interactive)
2625    (save-excursion    (save-excursion
2626      (let ((inhibit-point-motion-hooks t)      (let ((inhibit-point-motion-hooks t)
2627            buffer-read-only)            (inhibit-read-only t))
2628        (article-goto-body)        (article-goto-body)
2629        (while (re-search-forward "^[ \t]*\n" nil t)        (while (re-search-forward "^[ \t]*\n" nil t)
2630          (replace-match "" t t)))))          (replace-match "" t t)))))
# Line 1932  Point is left at the beginning of the na Line 2644  Point is left at the beginning of the na
2644                         (< (- (point-max) (point)) limit))                         (< (- (point-max) (point)) limit))
2645                    (and (floatp limit)                    (and (floatp limit)
2646                         (< (count-lines (point) (point-max)) limit))                         (< (count-lines (point) (point-max)) limit))
2647                    (and (gnus-functionp limit)                    (and (functionp limit)
2648                         (funcall limit))                         (funcall limit))
2649                    (and (stringp limit)                    (and (stringp limit)
2650                         (not (re-search-forward limit nil t))))                         (not (re-search-forward limit nil t))))
# Line 2007  Originally it is hide instead of DUMMY." Line 2719  Originally it is hide instead of DUMMY."
2719       'article-type type       'article-type type
2720       (point-min) (point-max)       (point-min) (point-max)
2721       (cons 'article-type (cons type       (cons 'article-type (cons type
2722                                 gnus-hidden-properties)))))                                 gnus-hidden-properties)))
2723        (gnus-delete-wash-type type)))
2724    
2725  (defconst article-time-units  (defconst article-time-units
2726    `((year . ,(* 365.25 24 60 60))    `((year . ,(* 365.25 24 60 60))
# Line 2018  Originally it is hide instead of DUMMY." Line 2731  Originally it is hide instead of DUMMY."
2731      (second . 1))      (second . 1))
2732    "Mapping from time units to seconds.")    "Mapping from time units to seconds.")
2733    
2734    (defun gnus-article-forward-header ()
2735      "Move point to the start of the next header.
2736    If the current header is a continuation header, this can be several
2737    lines forward."
2738      (let ((ended nil))
2739        (while (not ended)
2740          (forward-line 1)
2741          (if (looking-at "[ \t]+[^ \t]")
2742              (forward-line 1)
2743            (setq ended t)))))
2744    
2745  (defun article-date-ut (&optional type highlight header)  (defun article-date-ut (&optional type highlight header)
2746    "Convert DATE date to universal time in the current article.    "Convert DATE date to universal time in the current article.
2747  If TYPE is `local', convert to local time; if it is `lapsed', output  If TYPE is `local', convert to local time; if it is `lapsed', output
# Line 2029  should replace the \"Date:\" one, or sho Line 2753  should replace the \"Date:\" one, or sho
2753                       (message-fetch-field "date")                       (message-fetch-field "date")
2754                       ""))                       ""))
2755           (tdate-regexp "^Date:[ \t]\\|^X-Sent:[ \t]")           (tdate-regexp "^Date:[ \t]\\|^X-Sent:[ \t]")
2756           (date-regexp           (date-regexp
2757            (cond            (cond
2758             ((not gnus-article-date-lapsed-new-header)             ((not gnus-article-date-lapsed-new-header)
2759              tdate-regexp)              tdate-regexp)
# Line 2055  should replace the \"Date:\" one, or sho Line 2779  should replace the \"Date:\" one, or sho
2779          (when (and date (not (string= date "")))          (when (and date (not (string= date "")))
2780            (goto-char (point-min))            (goto-char (point-min))
2781            (let ((inhibit-read-only t))            (let ((inhibit-read-only t))
2782              ;; Delete any old Date headers.              ;; Delete any old Date headers.
2783              (while (re-search-forward date-regexp nil t)              (while (re-search-forward date-regexp nil t)
2784                (if pos                (if pos
2785                    (delete-region (progn (beginning-of-line) (point))                    (delete-region (progn (beginning-of-line) (point))
2786                                   (progn (forward-line 1) (point)))                                   (progn (gnus-article-forward-header)
2787                                            (point)))
2788                  (delete-region (progn (beginning-of-line) (point))                  (delete-region (progn (beginning-of-line) (point))
2789                                 (progn (end-of-line) (point)))                                   (progn (gnus-article-forward-header)
2790                                            (forward-char -1)
2791                                            (point)))
2792                  (setq pos (point))))                  (setq pos (point))))
2793              (when (and (not pos) (re-search-forward tdate-regexp nil t))              (when (and (not pos)
2794                           (re-search-forward tdate-regexp nil t))
2795                (forward-line 1))                (forward-line 1))
2796              (if pos (goto-char pos))              (when pos
2797                  (goto-char pos))
2798              (insert (article-make-date-line date (or type 'ut)))              (insert (article-make-date-line date (or type 'ut)))
2799              (when (not pos)              (unless pos
2800                (insert "\n")                (insert "\n")
2801                (forward-line -1))                (forward-line -1))
2802              ;; Do highlighting.              ;; Do highlighting.
# Line 2082  should replace the \"Date:\" one, or sho Line 2811  should replace the \"Date:\" one, or sho
2811    
2812  (defun article-make-date-line (date type)  (defun article-make-date-line (date type)
2813    "Return a DATE line of TYPE."    "Return a DATE line of TYPE."
2814    (let ((time (condition-case ()    (unless (memq type '(local ut original user iso8601 lapsed english))
2815                    (date-to-time date)      (error "Unknown conversion type: %s" type))
2816                  (error '(0 0)))))    (condition-case ()
2817      (cond        (let ((time (date-to-time date)))
      ;; Convert to the local timezone.  We have to slap a  
      ;; `condition-case' round the calls to the timezone  
      ;; functions since they aren't particularly resistant to  
      ;; buggy dates.  
      ((eq type 'local)  
       (let ((tz (car (current-time-zone time))))  
         (format "Date: %s %s%02d%02d" (current-time-string time)  
                 (if (> tz 0) "+" "-") (/ (abs tz) 3600)  
                 (/ (% (abs tz) 3600) 60))))  
      ;; Convert to Universal Time.  
      ((eq type 'ut)  
       (concat "Date: "  
               (current-time-string  
                (let* ((e (parse-time-string date))  
                       (tm (apply 'encode-time e))  
                       (ms (car tm))  
                       (ls (- (cadr tm) (car (current-time-zone time)))))  
                  (cond ((< ls 0) (list (1- ms) (+ ls 65536)))  
                        ((> ls 65535) (list (1+ ms) (- ls 65536)))  
                        (t (list ms ls)))))  
               " UT"))  
      ;; Get the original date from the article.  
      ((eq type 'original)  
       (concat "Date: " (if (string-match "\n+$" date)  
                            (substring date 0 (match-beginning 0))  
                          date)))  
      ;; Let the user define the format.  
      ((eq type 'user)  
       (if (gnus-functionp gnus-article-time-format)  
           (funcall gnus-article-time-format time)  
         (concat  
          "Date: "  
          (format-time-string gnus-article-time-format time))))  
      ;; ISO 8601.  
      ((eq type 'iso8601)  
       (let ((tz (car (current-time-zone time))))  
         (concat  
          "Date: "  
          (format-time-string "%Y%m%dT%H%M%S" time)  
          (format "%s%02d%02d"  
                  (if (> tz 0) "+" "-") (/ (abs tz) 3600)  
                  (/ (% (abs tz) 3600) 60)))))  
      ;; Do an X-Sent lapsed format.  
      ((eq type 'lapsed)  
       ;; If the date is seriously mangled, the timezone functions are  
       ;; liable to bug out, so we ignore all errors.  
       (let* ((now (current-time))  
              (real-time (subtract-time now time))  
              (real-sec (and real-time  
                             (+ (* (float (car real-time)) 65536)  
                                (cadr real-time))))  
              (sec (and real-time (abs real-sec)))  
              num prev)  
2818          (cond          (cond
2819           ((null real-time)           ;; Convert to the local timezone.
2820            "X-Sent: Unknown")           ((eq type 'local)
2821           ((zerop sec)            (let ((tz (car (current-time-zone time))))
2822            "X-Sent: Now")              (format "Date: %s %s%02d%02d" (current-time-string time)
2823           (t                      (if (> tz 0) "+" "-") (/ (abs tz) 3600)
2824            (concat                      (/ (% (abs tz) 3600) 60))))
2825             "X-Sent: "           ;; Convert to Universal Time.
2826             ;; This is a bit convoluted, but basically we go           ((eq type 'ut)
2827             ;; through the time units for years, weeks, etc,            (concat "Date: "
2828             ;; and divide things to see whether that results                    (current-time-string
2829             ;; in positive answers.                     (let* ((e (parse-time-string date))
2830             (mapconcat                            (tm (apply 'encode-time e))
2831              (lambda (unit)                            (ms (car tm))
2832                (if (zerop (setq num (ffloor (/ sec (cdr unit)))))                            (ls (- (cadr tm) (car (current-time-zone time)))))
2833                    ;; The (remaining) seconds are too few to                       (cond ((< ls 0) (list (1- ms) (+ ls 65536)))
2834                    ;; be divided into this time unit.                             ((> ls 65535) (list (1+ ms) (- ls 65536)))
2835                    ""                             (t (list ms ls)))))
2836                  ;; It's big enough, so we output it.                    " UT"))
2837                  (setq sec (- sec (* num (cdr unit))))           ;; Get the original date from the article.
2838                  (prog1           ((eq type 'original)
2839                      (concat (if prev ", " "") (int-to-string            (concat "Date: " (if (string-match "\n+$" date)
2840                                                 (floor num))                                 (substring date 0 (match-beginning 0))
2841                              " " (symbol-name (car unit))                               date)))
2842                              (if (> num 1) "s" ""))           ;; Let the user define the format.
2843                    (setq prev t))))           ((eq type 'user)
2844              article-time-units "")            (let ((format (or (condition-case nil
2845             ;; If dates are odd, then it might appear like the                                  (with-current-buffer gnus-summary-buffer
2846             ;; article was sent in the future.                                    gnus-article-time-format)
2847             (if (> real-sec 0)                                (error nil))
2848                 " ago"                              gnus-article-time-format)))
2849               " in the future"))))))              (if (functionp format)
2850       (t                  (funcall format time)
2851        (error "Unknown conversion type: %s" type)))))                (concat "Date: " (format-time-string format time)))))
2852             ;; ISO 8601.
2853             ((eq type 'iso8601)
2854              (let ((tz (car (current-time-zone time))))
2855                (concat
2856                 "Date: "
2857                 (format-time-string "%Y%m%dT%H%M%S" time)
2858                 (format "%s%02d%02d"
2859                         (if (> tz 0) "+" "-") (/ (abs tz) 3600)
2860                         (/ (% (abs tz) 3600) 60)))))
2861             ;; Do an X-Sent lapsed format.
2862             ((eq type 'lapsed)
2863              ;; If the date is seriously mangled, the timezone functions are
2864              ;; liable to bug out, so we ignore all errors.
2865              (let* ((now (current-time))
2866                     (real-time (subtract-time now time))
2867                     (real-sec (and real-time
2868                                    (+ (* (float (car real-time)) 65536)
2869                                       (cadr real-time))))
2870                     (sec (and real-time (abs real-sec)))
2871                     num prev)
2872                (cond
2873                 ((null real-time)
2874                  "X-Sent: Unknown")
2875                 ((zerop sec)
2876                  "X-Sent: Now")
2877                 (t
2878                  (concat
2879                   "X-Sent: "
2880                   ;; This is a bit convoluted, but basically we go
2881                   ;; through the time units for years, weeks, etc,
2882                   ;; and divide things to see whether that results
2883                   ;; in positive answers.
2884                   (mapconcat
2885                    (lambda (unit)
2886                      (if (zerop (setq num (ffloor (/ sec (cdr unit)))))
2887                          ;; The (remaining) seconds are too few to
2888                          ;; be divided into this time unit.
2889                          ""
2890                        ;; It's big enough, so we output it.
2891                        (setq sec (- sec (* num (cdr unit))))
2892                        (prog1
2893                            (concat (if prev ", " "") (int-to-string
2894                                                       (floor num))
2895                                    " " (symbol-name (car unit))
2896                                    (if (> num 1) "s" ""))
2897                          (setq prev t))))
2898                    article-time-units "")
2899                   ;; If dates are odd, then it might appear like the
2900                   ;; article was sent in the future.
2901                   (if (> real-sec 0)
2902                       " ago"
2903                     " in the future"))))))
2904             ;; Display the date in proper English
2905             ((eq type 'english)
2906              (let ((dtime (decode-time time)))
2907                (concat
2908                 "Date: the "
2909                 (number-to-string (nth 3 dtime))
2910                 (let ((digit (% (nth 3 dtime) 10)))
2911                   (cond
2912                    ((memq (nth 3 dtime) '(11 12 13)) "th")
2913                    ((= digit 1) "st")
2914                    ((= digit 2) "nd")
2915                    ((= digit 3) "rd")
2916                    (t "th")))
2917                 " of "
2918                 (nth (1- (nth 4 dtime)) gnus-english-month-names)
2919                 " "
2920                 (number-to-string (nth 5 dtime))
2921                 " at "
2922                 (format "%02d" (nth 2 dtime))
2923                 ":"
2924                 (format "%02d" (nth 1 dtime)))))))
2925        (error
2926         (format "Date: %s (from Gnus)" date))))
2927    
2928  (defun article-date-local (&optional highlight)  (defun article-date-local (&optional highlight)
2929    "Convert the current article date to the local timezone."    "Convert the current article date to the local timezone."
2930    (interactive (list t))    (interactive (list t))
2931    (article-date-ut 'local highlight))    (article-date-ut 'local highlight))
2932    
2933    (defun article-date-english (&optional highlight)
2934      "Convert the current article date to something that is proper English."
2935      (interactive (list t))
2936      (article-date-ut 'english highlight))
2937    
2938  (defun article-date-original (&optional highlight)  (defun article-date-original (&optional highlight)
2939    "Convert the current article date to what it was originally.    "Convert the current article date to what it was originally.
2940  This is only useful if you have used some other date conversion  This is only useful if you have used some other date conversion
# Line 2200  function and want to see what the date w Line 2956  function and want to see what the date w
2956           (lambda (w)           (lambda (w)
2957             (set-buffer (window-buffer w))             (set-buffer (window-buffer w))
2958             (when (eq major-mode 'gnus-article-mode)             (when (eq major-mode 'gnus-article-mode)
2959               (goto-char (point-min))               (let ((mark (point-marker)))
2960               (when (re-search-forward "^X-Sent:" nil t)                 (goto-char (point-min))
2961                 (article-date-lapsed t))))                 (when (re-search-forward "^X-Sent:" nil t)
2962                     (article-date-lapsed t))
2963                   (goto-char (marker-position mark))
2964                   (move-marker mark nil))))
2965           nil 'visible)))))           nil 'visible)))))
2966    
2967  (defun gnus-start-date-timer (&optional n)  (defun gnus-start-date-timer (&optional n)
# Line 2234  This format is defined by the `gnus-arti Line 2993  This format is defined by the `gnus-arti
2993    (interactive (list t))    (interactive (list t))
2994    (article-date-ut 'iso8601 highlight))    (article-date-ut 'iso8601 highlight))
2995    
2996  (defun article-show-all ()  ;; (defun article-show-all ()
2997    "Show all hidden text in the article buffer."  ;;   "Show all hidden text in the article buffer."
2998    ;;   (interactive)
2999    ;;   (save-excursion
3000    ;;     (let ((inhibit-read-only t))
3001    ;;       (gnus-article-unhide-text (point-min) (point-max)))))
3002    
3003    (defun article-remove-leading-whitespace ()
3004      "Remove excessive whitespace from all headers."
3005    (interactive)    (interactive)
3006    (save-excursion    (save-excursion
3007      (let ((inhibit-read-only t))      (save-restriction
3008        (gnus-article-unhide-text (point-min) (point-max)))))        (let ((inhibit-read-only t))
3009            (article-narrow-to-head)
3010            (goto-char (point-min))
3011            (while (re-search-forward "^[^ :]+: \\([ \t]+\\)" nil t)
3012              (delete-region (match-beginning 1) (match-end 1)))))))
3013    
3014  (defun article-emphasize (&optional arg)  (defun article-emphasize (&optional arg)
3015    "Emphasize text according to `gnus-emphasis-alist'."    "Emphasize text according to `gnus-emphasis-alist'."
# Line 2265  This format is defined by the `gnus-arti Line 3035  This format is defined by the `gnus-arti
3035                  visible (nth 2 elem)                  visible (nth 2 elem)
3036                  face (nth 3 elem))                  face (nth 3 elem))
3037            (while (re-search-forward regexp nil t)            (while (re-search-forward regexp nil t)
3038              (when (and (match-beginning visible) (match-beginning invisible))              (when (and (match-beginning visible) (match-beginning invisible))
3039                (push 'emphasis gnus-article-wash-types)                (gnus-article-hide-text
3040                (gnus-article-hide-text                 (match-beginning invisible) (match-end invisible) props)
3041                 (match-beginning invisible) (match-end invisible) props)                (gnus-article-unhide-text-type
3042                (gnus-article-unhide-text-type                 (match-beginning visible) (match-end visible) 'emphasis)
3043                 (match-beginning visible) (match-end visible) 'emphasis)                (gnus-put-overlay-excluding-newlines
3044                (gnus-put-text-property-excluding-newlines                 (match-beginning visible) (match-end visible) 'face face)
3045                 (match-beginning visible) (match-end visible) 'face face)                (gnus-add-wash-type 'emphasis)
3046                (goto-char (match-end invisible)))))))))                (goto-char (match-end invisible)))))))))
3047    
3048  (defun gnus-article-setup-highlight-words (&optional highlight-words)  (defun gnus-article-setup-highlight-words (&optional highlight-words)
3049    "Setup newsgroup emphasis alist."    "Setup newsgroup emphasis alist."
# Line 2375  This format is defined by the `gnus-arti Line 3145  This format is defined by the `gnus-arti
3145                        ;; A single split name was found                        ;; A single split name was found
3146                        ((= 1 (length split-name))                        ((= 1 (length split-name))
3147                         (let* ((name (expand-file-name                         (let* ((name (expand-file-name
3148                                       (car split-name) gnus-article-save-directory))                                       (car split-name)
3149                                         gnus-article-save-directory))
3150                                (dir (cond ((file-directory-p name)                                (dir (cond ((file-directory-p name)
3151                                            (file-name-as-directory name))                                            (file-name-as-directory name))
3152                                           ((file-exists-p name) name)                                           ((file-exists-p name) name)
# Line 2399  This format is defined by the `gnus-arti Line 3170  This format is defined by the `gnus-arti
3170                           (car (push result file-name-history)))))))                           (car (push result file-name-history)))))))
3171                 ;; Create the directory.                 ;; Create the directory.
3172                 (gnus-make-directory (file-name-directory file))                 (gnus-make-directory (file-name-directory file))
3173        ;; If we have read a directory, we append the default file name.                 ;; If we have read a directory, we append the default file name.
3174                 (when (file-directory-p file)                 (when (file-directory-p file)
3175                   (setq file (expand-file-name (file-name-nondirectory default-name)                   (setq file (expand-file-name (file-name-nondirectory
3176                                                   default-name)
3177                                                (file-name-as-directory file))))                                                (file-name-as-directory file))))
3178                 ;; Possibly translate some characters.                 ;; Possibly translate some characters.
3179                 (nnheader-translate-file-chars file))))))                 (nnheader-translate-file-chars file))))))
# Line 2448  Directory to save to is default to `gnus Line 3220  Directory to save to is default to `gnus
3220        (save-restriction        (save-restriction
3221          (widen)          (widen)
3222          (if (and (file-readable-p filename)          (if (and (file-readable-p filename)
3223                     (file-regular-p filename)
3224                   (mail-file-babyl-p filename))                   (mail-file-babyl-p filename))
3225              (rmail-output-to-rmail-file filename t)              (rmail-output-to-rmail-file filename t)
3226            (gnus-output-to-mail filename)))))            (gnus-output-to-mail filename)))))
# Line 2472  Directory to save to is default to `gnus Line 3245  Directory to save to is default to `gnus
3245    filename)    filename)
3246    
3247  (defun gnus-summary-write-to-file (&optional filename)  (defun gnus-summary-write-to-file (&optional filename)
3248    "Write this article to a file.    "Write this article to a file, overwriting it if the file exists.
3249  Optional argument FILENAME specifies file name.  Optional argument FILENAME specifies file name.
3250  The directory to save in defaults to `gnus-article-save-directory'."  The directory to save in defaults to `gnus-article-save-directory'."
3251    (gnus-summary-save-in-file nil t))    (gnus-summary-save-in-file nil t))
# Line 2521  The directory to save in defaults to `gn Line 3294  The directory to save in defaults to `gn
3294        (shell-command-on-region (point-min) (point-max) command nil)))        (shell-command-on-region (point-min) (point-max) command nil)))
3295    (setq gnus-last-shell-command command))    (setq gnus-last-shell-command command))
3296    
3297    (defmacro gnus-read-string (prompt &optional initial-contents history
3298                                default-value)
3299      "Like `read-string' but allow for older XEmacsen that don't have the 5th arg."
3300      (if (and (featurep 'xemacs)
3301               (< emacs-minor-version 2))
3302          `(read-string ,prompt ,initial-contents ,history)
3303        `(read-string ,prompt ,initial-contents ,history ,default-value)))
3304    
3305    (defun gnus-summary-pipe-to-muttprint (&optional command)
3306      "Pipe this article to muttprint."
3307      (setq command (gnus-read-string
3308                     "Print using command: " gnus-summary-muttprint-program
3309                     nil gnus-summary-muttprint-program))
3310      (gnus-summary-save-in-pipe command))
3311    
3312  ;;; Article file names when saving.  ;;; Article file names when saving.
3313    
3314  (defun gnus-capitalize-newsgroup (newsgroup)  (defun gnus-capitalize-newsgroup (newsgroup)
# Line 2573  If variable `gnus-use-long-file-name' is Line 3361  If variable `gnus-use-long-file-name' is
3361        (expand-file-name        (expand-file-name
3362         (if (gnus-use-long-file-name 'not-save)         (if (gnus-use-long-file-name 'not-save)
3363             newsgroup             newsgroup
3364           (expand-file-name "news" (gnus-newsgroup-directory-form newsgroup)))           (file-relative-name
3365              (expand-file-name "news" (gnus-newsgroup-directory-form newsgroup))
3366              default-directory))
3367         gnus-article-save-directory)))         gnus-article-save-directory)))
3368    
3369    (defun gnus-sender-save-name (newsgroup headers &optional last-file)
3370      "Generate file name from sender."
3371      (let ((from (mail-header-from headers)))
3372        (expand-file-name
3373         (if (and from (string-match "\\([^ <]+\\)@" from))
3374             (match-string 1 from)
3375           "nobody")
3376         gnus-article-save-directory)))
3377    
3378    (defun article-verify-x-pgp-sig ()
3379      "Verify X-PGP-Sig."
3380      (interactive)
3381      (if (gnus-buffer-live-p gnus-original-article-buffer)
3382          (let ((sig (with-current-buffer gnus-original-article-buffer
3383                       (gnus-fetch-field "X-PGP-Sig")))
3384                items info headers)
3385            (when (and sig
3386                       mml2015-use
3387                       (mml2015-clear-verify-function))
3388              (with-temp-buffer
3389                (insert-buffer-substring gnus-original-article-buffer)
3390                (setq items (split-string sig))
3391                (message-narrow-to-head)
3392                (let ((inhibit-point-motion-hooks t)
3393                      (case-fold-search t))
3394                  ;; Don't verify multiple headers.
3395                  (setq headers (mapconcat (lambda (header)
3396                                             (concat header ": "
3397                                                     (mail-fetch-field header)
3398                                                     "\n"))
3399                                           (split-string (nth 1 items) ",") "")))
3400                (delete-region (point-min) (point-max))
3401                (insert "-----BEGIN PGP SIGNED MESSAGE-----\n\n")
3402                (insert "X-Signed-Headers: " (nth 1 items) "\n")
3403                (insert headers)
3404                (widen)
3405                (forward-line)
3406                (while (not (eobp))
3407                  (if (looking-at "^-")
3408                      (insert "- "))
3409                  (forward-line))
3410                (insert "\n-----BEGIN PGP SIGNATURE-----\n")
3411                (insert "Version: " (car items) "\n\n")
3412                (insert (mapconcat 'identity (cddr items) "\n"))
3413                (insert "\n-----END PGP SIGNATURE-----\n")
3414                (let ((mm-security-handle (list (format "multipart/signed"))))
3415                  (mml2015-clean-buffer)
3416                  (let ((coding-system-for-write (or gnus-newsgroup-charset
3417                                                     'iso-8859-1)))
3418                    (funcall (mml2015-clear-verify-function)))
3419                  (setq info
3420                        (or (mm-handle-multipart-ctl-parameter
3421                             mm-security-handle 'gnus-details)
3422                            (mm-handle-multipart-ctl-parameter
3423                             mm-security-handle 'gnus-info)))))
3424              (when info
3425                (let ((inhibit-read-only t) bface eface)
3426                  (save-restriction
3427                    (message-narrow-to-head)
3428                    (goto-char (point-max))
3429                    (forward-line -1)
3430                    (setq bface (get-text-property (gnus-point-at-bol) 'face)
3431                          eface (get-text-property (1- (gnus-point-at-eol)) 'face))
3432                    (message-remove-header "X-Gnus-PGP-Verify")
3433                    (if (re-search-forward "^X-PGP-Sig:" nil t)
3434                        (forward-line)
3435                      (goto-char (point-max)))
3436                    (narrow-to-region (point) (point))
3437                    (insert "X-Gnus-PGP-Verify: " info "\n")
3438                    (goto-char (point-min))
3439                    (forward-line)
3440                    (while (not (eobp))
3441                      (if (not (looking-at "^[ \t]"))
3442                          (insert " "))
3443                      (forward-line))
3444                    ;; Do highlighting.
3445                    (goto-char (point-min))
3446                    (when (looking-at "\\([^:]+\\): *")
3447                      (put-text-property (match-beginning 1) (1+ (match-end 1))
3448                                         'face bface)
3449                      (put-text-property (match-end 0) (point-max)
3450                                         'face eface)))))))))
3451    
3452    (defun article-verify-cancel-lock ()
3453      "Verify Cancel-Lock header."
3454      (interactive)
3455      (if (gnus-buffer-live-p gnus-original-article-buffer)
3456          (canlock-verify gnus-original-article-buffer)))
3457    
3458  (eval-and-compile  (eval-and-compile
3459    (mapcar    (mapcar
3460     (lambda (func)     (lambda (func)
# Line 2586  If variable `gnus-use-long-file-name' is Line 3465  If variable `gnus-use-long-file-name' is
3465           (setq afunc func           (setq afunc func
3466                 gfunc (intern (format "gnus-%s" func))))                 gfunc (intern (format "gnus-%s" func))))
3467         (defalias gfunc         (defalias gfunc
3468           (if (fboundp afunc)           (when (fboundp afunc)
3469             `(lambda (&optional interactive &rest args)             `(lambda (&optional interactive &rest args)
3470                ,(documentation afunc t)                ,(documentation afunc t)
3471                (interactive (list t))                (interactive (list t))
# Line 2596  If variable `gnus-use-long-file-name' is Line 3475  If variable `gnus-use-long-file-name' is
3475                      (call-interactively ',afunc)                      (call-interactively ',afunc)
3476                    (apply ',afunc args))))))))                    (apply ',afunc args))))))))
3477     '(article-hide-headers     '(article-hide-headers
3478         article-verify-x-pgp-sig
3479         article-verify-cancel-lock
3480       article-hide-boring-headers       article-hide-boring-headers
3481       article-treat-overstrike       article-treat-overstrike
3482       article-fill-long-lines       article-fill-long-lines
3483       article-capitalize-sentences       article-capitalize-sentences
3484       article-remove-cr       article-remove-cr
3485         article-remove-leading-whitespace
3486       article-display-x-face       article-display-x-face
3487         article-display-face
3488       article-de-quoted-unreadable       article-de-quoted-unreadable
3489       article-de-base64-unreadable       article-de-base64-unreadable
3490       article-decode-HZ       article-decode-HZ
3491       article-wash-html       article-wash-html
3492         article-unsplit-urls
3493       article-hide-list-identifiers       article-hide-list-identifiers
      article-hide-pgp  
3494       article-strip-banner       article-strip-banner
3495       article-babel       article-babel
3496       article-hide-pem       article-hide-pem
# Line 2621  If variable `gnus-use-long-file-name' is Line 3504  If variable `gnus-use-long-file-name' is
3504       article-strip-blank-lines       article-strip-blank-lines
3505       article-strip-all-blank-lines       article-strip-all-blank-lines
3506       article-date-local       article-date-local
3507         article-date-english
3508       article-date-iso8601       article-date-iso8601
3509       article-date-original       article-date-original
3510       article-date-ut       article-date-ut
# Line 2632  If variable `gnus-use-long-file-name' is Line 3516  If variable `gnus-use-long-file-name' is
3516       article-emphasize       article-emphasize
3517       article-treat-dumbquotes       article-treat-dumbquotes
3518       article-normalize-headers       article-normalize-headers
3519       (article-show-all . gnus-article-show-all-headers))))  ;;     (article-show-all . gnus-article-show-all-headers)
3520         )))
3521    
3522  ;;;  ;;;
3523  ;;; Gnus article mode  ;;; Gnus article mode
# Line 2657  If variable `gnus-use-long-file-name' is Line 3542  If variable `gnus-use-long-file-name' is
3542    ">" end-of-buffer    ">" end-of-buffer
3543    "\C-c\C-i" gnus-info-find-node    "\C-c\C-i" gnus-info-find-node
3544    "\C-c\C-b" gnus-bug    "\C-c\C-b" gnus-bug
3545      "R" gnus-article-reply-with-original
3546      "F" gnus-article-followup-with-original
3547    "\C-hk" gnus-article-describe-key    "\C-hk" gnus-article-describe-key
3548    "\C-hc" gnus-article-describe-key-briefly    "\C-hc" gnus-article-describe-key-briefly
3549    
# Line 2669  If variable `gnus-use-long-file-name' is Line 3556  If variable `gnus-use-long-file-name' is
3556  (substitute-key-definition  (substitute-key-definition
3557   'undefined 'gnus-article-read-summary-keys gnus-article-mode-map)   'undefined 'gnus-article-read-summary-keys gnus-article-mode-map)
3558    
 (defvar gnus-article-post-menu nil)  
   
3559  (defun gnus-article-make-menu-bar ()  (defun gnus-article-make-menu-bar ()
3560      (unless (boundp 'gnus-article-commands-menu)
3561        (gnus-summary-make-menu-bar))
3562    (gnus-turn-off-edit-menu 'article)    (gnus-turn-off-edit-menu 'article)
3563    (unless (boundp 'gnus-article-article-menu)    (unless (boundp 'gnus-article-article-menu)
3564      (easy-menu-define      (easy-menu-define
# Line 2693  If variable `gnus-use-long-file-name' is Line 3580  If variable `gnus-use-long-file-name' is
3580         ["Hide citation" gnus-article-hide-citation t]         ["Hide citation" gnus-article-hide-citation t]
3581         ["Treat overstrike" gnus-article-treat-overstrike t]         ["Treat overstrike" gnus-article-treat-overstrike t]
3582         ["Remove carriage return" gnus-article-remove-cr t]         ["Remove carriage return" gnus-article-remove-cr t]
3583           ["Remove leading whitespace" gnus-article-remove-leading-whitespace t]
3584         ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t]         ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t]
3585         ["Remove base64" gnus-article-de-base64-unreadable t]         ["Remove base64" gnus-article-de-base64-unreadable t]
3586         ["Treat html" gnus-article-wash-html t]         ["Treat html" gnus-article-wash-html t]
3587           ["Remove newlines from within URLs" gnus-article-unsplit-urls t]
3588         ["Decode HZ" gnus-article-decode-HZ t]))         ["Decode HZ" gnus-article-decode-HZ t]))
3589    
3590      ;; Note "Commands" menu is defined in gnus-sum.el for consistency      ;; Note "Commands" menu is defined in gnus-sum.el for consistency
3591    
3592      (when (boundp 'gnus-summary-post-menu)      ;; Note "Post" menu is defined in gnus-sum.el for consistency
       (cond  
        ((not (keymapp gnus-summary-post-menu))  
         (setq gnus-article-post-menu gnus-summary-post-menu))  
        ((not gnus-article-post-menu)  
         ;; Don't share post menu.  
         (setq gnus-article-post-menu  
               (copy-keymap gnus-summary-post-menu))))  
       (define-key gnus-article-mode-map [menu-bar post]  
         (cons "Post" gnus-article-post-menu)))  
3593    
3594      (gnus-run-hooks 'gnus-article-menu-hook)))      (gnus-run-hooks 'gnus-article-menu-hook)))
3595    
 ;; Fixme: do something for the Emacs tool bar in Article mode a la  
 ;; Summary.  
   
3596  (defun gnus-article-mode ()  (defun gnus-article-mode ()
3597    "Major mode for displaying an article.    "Major mode for displaying an article.
3598    
# Line 2738  commands: Line 3615  commands:
3615    (make-local-variable 'minor-mode-alist)    (make-local-variable 'minor-mode-alist)
3616    (use-local-map gnus-article-mode-map)    (use-local-map gnus-article-mode-map)
3617    (when (gnus-visual-p 'article-menu 'menu)    (when (gnus-visual-p 'article-menu 'menu)
3618      (gnus-article-make-menu-bar))      (gnus-article-make-menu-bar)
3619        (when gnus-summary-tool-bar-map
3620          (set (make-local-variable 'tool-bar-map) gnus-summary-tool-bar-map)))
3621    (gnus-update-format-specifications nil 'article-mode)    (gnus-update-format-specifications nil 'article-mode)
3622    (set (make-local-variable 'page-delimiter) gnus-page-delimiter)    (set (make-local-variable 'page-delimiter) gnus-page-delimiter)
3623    (make-local-variable 'gnus-page-broken)    (set (make-local-variable 'gnus-page-broken) nil)
3624    (make-local-variable 'gnus-button-marker-list)    (make-local-variable 'gnus-button-marker-list)
3625    (make-local-variable 'gnus-article-current-summary)    (make-local-variable 'gnus-article-current-summary)
3626    (make-local-variable 'gnus-article-mime-handles)    (make-local-variable 'gnus-article-mime-handles)
3627    (make-local-variable 'gnus-article-decoded-p)    (make-local-variable 'gnus-article-decoded-p)
3628    (make-local-variable 'gnus-article-mime-handle-alist)    (make-local-variable 'gnus-article-mime-handle-alist)
3629    (make-local-variable 'gnus-article-wash-types)    (make-local-variable 'gnus-article-wash-types)
3630      (make-local-variable 'gnus-article-image-alist)
3631      (make-local-variable 'gnus-article-charset)
3632      (make-local-variable 'gnus-article-ignored-charsets)
3633    (gnus-set-default-directory)    (gnus-set-default-directory)
3634    (buffer-disable-undo)    (buffer-disable-undo)
3635    (setq buffer-read-only t)    (setq buffer-read-only t)
# Line 2783  commands: Line 3665  commands:
3665      (if (get-buffer name)      (if (get-buffer name)
3666          (save-excursion          (save-excursion
3667            (set-buffer name)            (set-buffer name)
3668              (when (and gnus-article-edit-mode
3669                         (buffer-modified-p)
3670                         (not
3671                          (y-or-n-p "Article mode edit in progress; discard? ")))
3672                (error "Action aborted"))
3673              (set (make-local-variable 'gnus-article-edit-mode) nil)
3674            (when gnus-article-mime-handles            (when gnus-article-mime-handles
3675              (mm-destroy-parts gnus-article-mime-handles)              (mm-destroy-parts gnus-article-mime-handles)
3676              (setq gnus-article-mime-handles nil))              (setq gnus-article-mime-handles nil))
# Line 2790  commands: Line 3678  commands:
3678            (setq gnus-article-mime-handle-alist nil)            (setq gnus-article-mime-handle-alist nil)
3679            (buffer-disable-undo)            (buffer-disable-undo)
3680            (setq buffer-read-only t)            (setq buffer-read-only t)
3681              ;; This list just keeps growing if we don't reset it.
3682              (setq gnus-button-marker-list nil)
3683            (unless (eq major-mode 'gnus-article-mode)            (unless (eq major-mode 'gnus-article-mode)
3684              (gnus-article-mode))              (gnus-article-mode))
3685            (current-buffer))            (current-buffer))
# Line 2804  commands: Line 3694  commands:
3694  ;; from the head of the article.  ;; from the head of the article.
3695  (defun gnus-article-set-window-start (&optional line)  (defun gnus-article-set-window-start (&optional line)
3696    (set-window-start    (set-window-start
3697     (get-buffer-window gnus-article-buffer t)     (gnus-get-buffer-window gnus-article-buffer t)
3698     (save-excursion     (save-excursion
3699       (set-buffer gnus-article-buffer)       (set-buffer gnus-article-buffer)
3700       (goto-char (point-min))       (goto-char (point-min))
# Line 2848  If ALL-HEADERS is non-nil, no headers ar Line 3738  If ALL-HEADERS is non-nil, no headers ar
3738                        (cons gnus-newsgroup-name article))                        (cons gnus-newsgroup-name article))
3739                  (set-buffer gnus-summary-buffer)                  (set-buffer gnus-summary-buffer)
3740                  (setq gnus-current-article article)                  (setq gnus-current-article article)
3741                  (if (eq (gnus-article-mark article) gnus-undownloaded-mark)                  (if (and (memq article gnus-newsgroup-undownloaded)
3742                             (not (gnus-online (gnus-find-method-for-group
3743                                                gnus-newsgroup-name))))
3744                      (progn                      (progn
3745                        (gnus-summary-set-agent-mark article)                        (gnus-summary-set-agent-mark article)
3746                        (message "Message marked for downloading"))                        (message "Message marked for downloading"))
# Line 2912  If ALL-HEADERS is non-nil, no headers ar Line 3804  If ALL-HEADERS is non-nil, no headers ar
3804                (gnus-article-prepare-display)                (gnus-article-prepare-display)
3805                ;; Do page break.                ;; Do page break.
3806                (goto-char (point-min))                (goto-char (point-min))
3807                (setq gnus-page-broken                (when gnus-break-pages
3808                      (when gnus-break-pages                  (gnus-narrow-to-page)))
                       (gnus-narrow-to-page)  
                       t)))  
3809              (let ((gnus-article-mime-handle-alist-1              (let ((gnus-article-mime-handle-alist-1
3810                     gnus-article-mime-handle-alist))                     gnus-article-mime-handle-alist))
3811                (gnus-set-mode-line 'article))                (gnus-set-mode-line 'article))
3812              (article-goto-body)              (article-goto-body)
3813                (unless (bobp)
3814                  (forward-line -1))
3815              (set-window-point (get-buffer-window (current-buffer)) (point))              (set-window-point (get-buffer-window (current-buffer)) (point))
3816              (gnus-configure-windows 'article)              (gnus-configure-windows 'article)
3817              t))))))              t))))))
# Line 2930  If ALL-HEADERS is non-nil, no headers ar Line 3822  If ALL-HEADERS is non-nil, no headers ar
3822    ;; Hooks for getting information from the article.    ;; Hooks for getting information from the article.
3823    ;; This hook must be called before being narrowed.    ;; This hook must be called before being narrowed.
3824    (let ((gnus-article-buffer (current-buffer))    (let ((gnus-article-buffer (current-buffer))
3825          buffer-read-only)          buffer-read-only
3826            (inhibit-read-only t))
3827      (unless (eq major-mode 'gnus-article-mode)      (unless (eq major-mode 'gnus-article-mode)
3828        (gnus-article-mode))        (gnus-article-mode))
3829      (setq buffer-read-only nil      (setq buffer-read-only nil
3830            gnus-article-wash-types nil)            gnus-article-wash-types nil
3831              gnus-article-image-alist nil)
3832      (gnus-run-hooks 'gnus-tmp-internal-hook)      (gnus-run-hooks 'gnus-tmp-internal-hook)
3833      (when gnus-display-mime-function      (when gnus-display-mime-function
3834        (funcall gnus-display-mime-function))        (funcall gnus-display-mime-function))
# Line 2945  If ALL-HEADERS is non-nil, no headers ar Line 3839  If ALL-HEADERS is non-nil, no headers ar
3839  ;;;  ;;;
3840    
3841  (defvar gnus-mime-button-line-format "%{%([%p. %d%T]%)%}%e\n"  (defvar gnus-mime-button-line-format "%{%([%p. %d%T]%)%}%e\n"
3842    "The following specs can be used:    "Format of the MIME buttons.
3843    
3844    Valid specifiers include:
3845  %t  The MIME type  %t  The MIME type
3846  %T  MIME type, along with additional info  %T  MIME type, along with additional info
3847  %n  The `name' parameter  %n  The `name' parameter
3848  %d  The description, if any  %d  The description, if any
3849  %l  The length of the encoded part  %l  The length of the encoded part
3850  %p  The part identifier number  %p  The part identifier number
3851  %e  Dots if the part isn't displayed")  %e  Dots if the part isn't displayed
3852    
3853    General format specifiers can also be used.  See Info node
3854    `(gnus)Formatting Variables'.")
3855    
3856  (defvar gnus-mime-button-line-format-alist  (defvar gnus-mime-button-line-format-alist
3857    '((?t gnus-tmp-type ?s)    '((?t gnus-tmp-type ?s)
# Line 2967  If ALL-HEADERS is non-nil, no headers ar Line 3866  If ALL-HEADERS is non-nil, no headers ar
3866    '((gnus-article-press-button "\r" "Toggle Display")    '((gnus-article-press-button "\r" "Toggle Display")
3867      (gnus-mime-view-part "v" "View Interactively...")      (gnus-mime-view-part "v" "View Interactively...")
3868      (gnus-mime-view-part-as-type "t" "View As Type...")      (gnus-mime-view-part-as-type "t" "View As Type...")
3869        (gnus-mime-view-part-as-charset "C" "View As charset...")
3870      (gnus-mime-save-part "o" "Save...")      (gnus-mime-save-part "o" "Save...")
3871        (gnus-mime-save-part-and-strip "\C-o" "Save and Strip")
3872        (gnus-mime-delete-part "d" "Delete part")
3873      (gnus-mime-copy-part "c" "View As Text, In Other Buffer")      (gnus-mime-copy-part "c" "View As Text, In Other Buffer")
3874      (gnus-mime-inline-part "i" "View As Text, In This Buffer")      (gnus-mime-inline-part "i" "View As Text, In This Buffer")
3875      (gnus-mime-internalize-part "E" "View Internally")      (gnus-mime-view-part-internally "E" "View Internally")
3876      (gnus-mime-externalize-part "e" "View Externally")      (gnus-mime-view-part-externally "e" "View Externally")
3877        (gnus-mime-print-part "p" "Print")
3878      (gnus-mime-pipe-part "|" "Pipe To Command...")      (gnus-mime-pipe-part "|" "Pipe To Command...")
3879      (gnus-mime-action-on-part "." "Take action on the part")))      (gnus-mime-action-on-part "." "Take action on the part...")))
3880    
3881  (defun gnus-article-mime-part-status ()  (defun gnus-article-mime-part-status ()
3882    (if gnus-article-mime-handle-alist-1    (if gnus-article-mime-handle-alist-1
3883        (format " (%d parts)" (length gnus-article-mime-handle-alist-1))        (if (eq 1 (length gnus-article-mime-handle-alist-1))
3884              " (1 part)"
3885            (format " (%d parts)" (length gnus-article-mime-handle-alist-1)))
3886      ""))      ""))
3887    
3888  (defvar gnus-mime-button-map  (defvar gnus-mime-button-map
3889    (let ((map (make-sparse-keymap)))    (let ((map (make-sparse-keymap)))
3890      ;; Not for Emacs 21: fixme better.      (unless (>= (string-to-number emacs-version) 21)
3891      ;; (set-keymap-parent map gnus-article-mode-map)        ;; XEmacs doesn't care.
3892          (set-keymap-parent map gnus-article-mode-map))
3893      (define-key map gnus-mouse-2 'gnus-article-push-button)      (define-key map gnus-mouse-2 'gnus-article-push-button)
3894      (define-key map gnus-down-mouse-3 'gnus-mime-button-menu)      (define-key map gnus-down-mouse-3 'gnus-mime-button-menu)
3895      (dolist (c gnus-mime-button-commands)      (dolist (c gnus-mime-button-commands)
3896        (define-key map (cadr c) (car c)))        (define-key map (cadr c) (car c)))
3897      map))      map))
3898    
3899  (defun gnus-mime-button-menu (event)  (easy-menu-define
3900    "Construct a context-sensitive menu of MIME commands."    gnus-mime-button-menu gnus-mime-button-map "MIME button menu."
3901    (interactive "e")    `("MIME Part"
3902    (save-excursion      ,@(mapcar (lambda (c)
3903      (mouse-set-point event)                  (vector (caddr c) (car c) :enable t))
3904      (gnus-article-check-buffer)                gnus-mime-button-commands)))
3905      (let ((response (x-popup-menu  
3906                       t `("MIME Part"  (eval-when-compile
3907                           ("" ,@(mapcar (lambda (c)    (define-compiler-macro popup-menu (&whole form
3908                                           (cons (caddr c) (car c)))                                              menu &optional position prefix)
3909                                         gnus-mime-button-commands))))))      (if (and (fboundp 'popup-menu)
3910        (if response               (not (memq 'popup-menu (assoc "lmenu" load-history))))
3911            (call-interactively response)))))          form
3912          ;; Gnus is probably running under Emacs 20.
3913          `(let* ((menu (cdr ,menu))
3914                  (response (x-popup-menu
3915                             t (list (car menu)
3916                                     (cons "" (mapcar (lambda (c)
3917                                                        (cons (caddr c) (car c)))
3918                                                      (cdr menu)))))))
3919             (if response
3920                 (call-interactively (nth 3 (assq response menu))))))))
3921    
3922    (defun gnus-mime-button-menu (event prefix)
3923     "Construct a context-sensitive menu of MIME commands."
3924     (interactive "e\nP")
3925     (save-window-excursion
3926       (let ((pos (event-start event)))
3927         (select-window (posn-window pos))
3928         (goto-char (posn-point pos))
3929         (gnus-article-check-buffer)
3930         (popup-menu gnus-mime-button-menu nil prefix))))
3931    
3932  (defun gnus-mime-view-all-parts (&optional handles)  (defun gnus-mime-view-all-parts (&optional handles)
3933    "View all the MIME parts."    "View all the MIME parts."
# Line 3012  If ALL-HEADERS is non-nil, no headers ar Line 3937  If ALL-HEADERS is non-nil, no headers ar
3937      (let ((handles (or handles gnus-article-mime-handles))      (let ((handles (or handles gnus-article-mime-handles))
3938            (mail-parse-charset gnus-newsgroup-charset)            (mail-parse-charset gnus-newsgroup-charset)
3939            (mail-parse-ignored-charsets            (mail-parse-ignored-charsets
3940             (save-excursion (set-buffer gnus-summary-buffer)             (with-current-buffer gnus-summary-buffer
3941                             gnus-newsgroup-ignored-charsets)))               gnus-newsgroup-ignored-charsets)))
3942        (if (stringp (car handles))        (when handles
3943            (gnus-mime-view-all-parts (cdr handles))          (mm-remove-parts handles)
3944          (mapcar 'mm-display-part handles)))))          (goto-char (point-min))
3945            (or (search-forward "\n\n") (goto-char (point-max)))
3946            (let ((inhibit-read-only t))
3947              (delete-region (point) (point-max))
3948              (mm-display-parts handles))))))
3949    
3950    (defun gnus-mime-save-part-and-strip ()
3951      "Save the MIME part under point then replace it with an external body."
3952      (interactive)
3953      (gnus-article-check-buffer)
3954      (when (gnus-group-read-only-p)
3955        (error "The current group does not support deleting of parts"))
3956      (when (mm-complicated-handles gnus-article-mime-handles)
3957        (error "\
3958    The current article has a complicated MIME structure, giving up..."))
3959      (when (gnus-yes-or-no-p "\
3960    Deleting parts may malfunction or destroy the article; continue? ")
3961        (let* ((data (get-text-property (point) 'gnus-data))
3962               file param
3963               (handles gnus-article-mime-handles))
3964          (setq file (and data (mm-save-part data)))
3965          (when file
3966            (with-current-buffer (mm-handle-buffer data)
3967              (erase-buffer)
3968              (insert "Content-Type: " (mm-handle-media-type data))
3969              (mml-insert-parameter-string (cdr (mm-handle-type data))
3970                                           '(charset))
3971              (insert "\n")
3972              (insert "Content-ID: " (message-make-message-id) "\n")
3973              (insert "Content-Transfer-Encoding: binary\n")
3974              (insert "\n"))
3975            (setcdr data
3976                    (cdr (mm-make-handle nil
3977                                         `("message/external-body"
3978                                           (access-type . "LOCAL-FILE")
3979                                           (name . ,file)))))
3980            (set-buffer gnus-summary-buffer)
3981            (gnus-article-edit-article
3982             `(lambda ()
3983                (erase-buffer)
3984                (let ((mail-parse-charset (or gnus-article-charset
3985                                              ',gnus-newsgroup-charset))
3986                      (mail-parse-ignored-charsets
3987                       (or gnus-article-ignored-charsets
3988                           ',gnus-newsgroup-ignored-charsets))
3989                      (mbl mml-buffer-list))
3990                  (setq mml-buffer-list nil)
3991                  (insert-buffer gnus-original-article-buffer)
3992                  (mime-to-mml ',handles)
3993                  (setq gnus-article-mime-handles nil)
3994                  (let ((mbl1 mml-buffer-list))
3995                    (setq mml-buffer-list mbl)
3996                    (set (make-local-variable 'mml-buffer-list) mbl1))
3997                  (gnus-make-local-hook 'kill-buffer-hook)
3998                  (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t)))
3999             `(lambda (no-highlight)
4000                (let ((mail-parse-charset (or gnus-article-charset
4001                                              ',gnus-newsgroup-charset))
4002                      (message-options message-options)
4003                      (message-options-set-recipient)
4004                      (mail-parse-ignored-charsets
4005                       (or gnus-article-ignored-charsets
4006                           ',gnus-newsgroup-ignored-charsets)))
4007                  (mml-to-mime)
4008                  (mml-destroy-buffers)
4009                  (remove-hook 'kill-buffer-hook
4010                               'mml-destroy-buffers t)
4011                  (kill-local-variable 'mml-buffer-list))
4012                (gnus-summary-edit-article-done
4013                 ,(or (mail-header-references gnus-current-headers) "")
4014                 ,(gnus-group-read-only-p)
4015                 ,gnus-summary-buffer no-highlight)))))))
4016    
4017    (defun gnus-mime-delete-part ()
4018      "Delete the MIME part under point.
4019    Replace it with some information about the removed part."
4020      (interactive)
4021      (gnus-article-check-buffer)
4022      (when (gnus-group-read-only-p)
4023        (error "The current group does not support deleting of parts"))
4024      (when (mm-complicated-handles gnus-article-mime-handles)
4025        (error "\
4026    The current article has a complicated MIME structure, giving up..."))
4027      (when (gnus-yes-or-no-p "\
4028    Deleting parts may malfunction or destroy the article; continue? ")
4029        (let* ((data (get-text-property (point) 'gnus-data))
4030               (handles gnus-article-mime-handles)
4031               (none "(none)")
4032               (description
4033                (or
4034                 (mail-decode-encoded-word-string (or (mm-handle-description data)
4035                                                      none))))
4036               (filename
4037                (or (mail-content-type-get (mm-handle-disposition data) 'filename)
4038                    none))
4039               (type (mm-handle-media-type data)))
4040          (unless data
4041            (error "No MIME part under point"))
4042          (with-current-buffer (mm-handle-buffer data)
4043            (let ((bsize (format "%s" (buffer-size))))
4044              (erase-buffer)
4045              (insert
4046               (concat
4047                ",----\n"
4048                "| The following attachment has been deleted:\n"
4049                "|\n"
4050                "| Type:           " type "\n"
4051                "| Filename:       " filename "\n"
4052                "| Size (encoded): " bsize " Byte\n"
4053                "| Description:    " description "\n"
4054                "`----\n"))
4055              (setcdr data
4056                      (cdr (mm-make-handle
4057                            nil `("text/plain") nil nil
4058                            (list "attachment")
4059                            (format "Deleted attachment (%s bytes)" bsize))))))
4060          (set-buffer gnus-summary-buffer)
4061          ;; FIXME: maybe some of the following code (borrowed from
4062          ;; `gnus-mime-save-part-and-strip') isn't necessary?
4063          (gnus-article-edit-article
4064           `(lambda ()
4065              (erase-buffer)
4066              (let ((mail-parse-charset (or gnus-article-charset
4067                                            ',gnus-newsgroup-charset))
4068                    (mail-parse-ignored-charsets
4069                     (or gnus-article-ignored-charsets
4070                         ',gnus-newsgroup-ignored-charsets))
4071                    (mbl mml-buffer-list))
4072                (setq mml-buffer-list nil)
4073                (insert-buffer gnus-original-article-buffer)
4074                (mime-to-mml ',handles)
4075                (setq gnus-article-mime-handles nil)
4076                (let ((mbl1 mml-buffer-list))
4077                  (setq mml-buffer-list mbl)
4078                  (set (make-local-variable 'mml-buffer-list) mbl1))
4079                (gnus-make-local-hook 'kill-buffer-hook)
4080                (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t)))
4081           `(lambda (no-highlight)
4082              (let ((mail-parse-charset (or gnus-article-charset
4083                                            ',gnus-newsgroup-charset))
4084                    (message-options message-options)
4085                    (message-options-set-recipient)
4086                    (mail-parse-ignored-charsets
4087                     (or gnus-article-ignored-charsets
4088                         ',gnus-newsgroup-ignored-charsets)))
4089                (mml-to-mime)
4090                (mml-destroy-buffers)
4091                (remove-hook 'kill-buffer-hook
4092                             'mml-destroy-buffers t)
4093                (kill-local-variable 'mml-buffer-list))
4094              (gnus-summary-edit-article-done
4095               ,(or (mail-header-references gnus-current-headers) "")
4096               ,(gnus-group-read-only-p)
4097               ,gnus-summary-buffer no-highlight)))))
4098      ;; Not in `gnus-mime-save-part-and-strip':
4099      (gnus-article-edit-done)
4100      (gnus-summary-expand-window)
4101      (gnus-summary-show-article))
4102    
4103  (defun gnus-mime-save-part ()  (defun gnus-mime-save-part ()
4104    "Save the MIME part under point."    "Save the MIME part under point."
4105    (interactive)    (interactive)
4106    (gnus-article-check-buffer)    (gnus-article-check-buffer)
4107    (let ((data (get-text-property (point) 'gnus-data)))    (let ((data (get-text-property (point) 'gnus-data)))
4108      (mm-save-part data)))      (when data
4109          (mm-save-part data))))
4110    
4111  (defun gnus-mime-pipe-part ()  (defun gnus-mime-pipe-part ()
4112    "Pipe the MIME part under point to a process."    "Pipe the MIME part under point to a process."
4113    (interactive)    (interactive)
4114    (gnus-article-check-buffer)    (gnus-article-check-buffer)
4115    (let ((data (get-text-property (point) 'gnus-data)))    (let ((data (get-text-property (point) 'gnus-data)))
4116      (mm-pipe-part data)))      (when data
4117          (mm-pipe-part data))))
4118    
4119  (defun gnus-mime-view-part ()  (defun gnus-mime-view-part ()
4120    "Interactively choose a viewing method for the MIME part under point."    "Interactively choose a viewing method for the MIME part under point."
4121    (interactive)    (interactive)
4122    (gnus-article-check-buffer)    (gnus-article-check-buffer)
4123    (let ((data (get-text-property (point) 'gnus-data)))    (let ((data (get-text-property (point) 'gnus-data)))
4124      (push (setq data (copy-sequence data)) gnus-article-mime-handles)      (when data
4125      (mm-interactively-view-part data)))        (setq gnus-article-mime-handles
4126                (mm-merge-handles
4127                 gnus-article-mime-handles (setq data (copy-sequence data))))
4128          (mm-interactively-view-part data))))
4129    
4130  (defun gnus-mime-view-part-as-type-internal ()  (defun gnus-mime-view-part-as-type-internal ()
4131    (gnus-article-check-buffer)    (gnus-article-check-buffer)
# Line 3048  If ALL-HEADERS is non-nil, no headers ar Line 4135  If ALL-HEADERS is non-nil, no headers ar
4135           (def-type (and name (mm-default-file-encoding name))))           (def-type (and name (mm-default-file-encoding name))))
4136      (and def-type (cons def-type 0))))      (and def-type (cons def-type 0))))
4137    
4138  (defun gnus-mime-view-part-as-type (mime-type)  (defun gnus-mime-view-part-as-type (&optional mime-type)
4139    "Choose a MIME media type, and view the part as such."    "Choose a MIME media type, and view the part as such."
4140    (interactive    (interactive)
4141     (list (completing-read    (unless mime-type
4142            "View as MIME type: "      (setq mime-type (completing-read
4143            (mapcar #'list (mailcap-mime-types))                       "View as MIME type: "
4144            nil nil                       (mapcar #'list (mailcap-mime-types))
4145            (gnus-mime-view-part-as-type-internal))))                       nil nil
4146                         (gnus-mime-view-part-as-type-internal))))
4147    (gnus-article-check-buffer)    (gnus-article-check-buffer)
4148    (let ((handle (get-text-property (point) 'gnus-data)))    (let ((handle (get-text-property (point) 'gnus-data)))
4149      (gnus-mm-display-part      (when handle
4150       (mm-make-handle (mm-handle-buffer handle)        (setq handle
4151                       (cons mime-type (cdr (mm-handle-type handle)))              (mm-make-handle (mm-handle-buffer handle)
4152                       (mm-handle-encoding handle)                              (cons mime-type (cdr (mm-handle-type handle)))
4153                       (mm-handle-undisplayer handle)                              (mm-handle-encoding handle)
4154                       (mm-handle-disposition handle)                              (mm-handle-undisplayer handle)
4155                       (mm-handle-description handle)                              (mm-handle-disposition handle)
4156                       (mm-handle-cache handle)                              (mm-handle-description handle)
4157                       (mm-handle-id handle)))))                              nil
4158                                (mm-handle-id handle)))
4159          (setq gnus-article-mime-handles
4160                (mm-merge-handles gnus-article-mime-handles handle))
4161          (gnus-mm-display-part handle))))
4162    
4163    (eval-when-compile
4164      (require 'jka-compr))
4165    
4166    ;; jka-compr.el uses a "sh -c" to direct stderr to err-file, but these days
4167    ;; emacs can do that itself.
4168    ;;
4169    (defun gnus-mime-jka-compr-maybe-uncompress ()
4170      "Uncompress the current buffer if `auto-compression-mode' is enabled.
4171    The uncompress method used is derived from `buffer-file-name'."
4172      (when (and (fboundp 'jka-compr-installed-p)
4173                 (jka-compr-installed-p))
4174        (let ((info (jka-compr-get-compression-info buffer-file-name)))
4175          (when info
4176            (let ((basename (file-name-nondirectory buffer-file-name))
4177                  (args     (jka-compr-info-uncompress-args    info))
4178                  (prog     (jka-compr-info-uncompress-program info))
4179                  (message  (jka-compr-info-uncompress-message info))
4180                  (err-file (jka-compr-make-temp-name)))
4181              (if message
4182                  (message "%s %s..." message basename))
4183              (unwind-protect
4184                  (unless (memq (apply 'call-process-region
4185                                       (point-min) (point-max)
4186                                       prog
4187                                       t (list t err-file) nil
4188                                       args)
4189                                jka-compr-acceptable-retval-list)
4190                    (jka-compr-error prog args basename message err-file))
4191                (jka-compr-delete-temp-file err-file)))))))
4192    
4193  (defun gnus-mime-copy-part (&optional handle)  (defun gnus-mime-copy-part (&optional handle)
4194    "Put the MIME part under point into a new buffer."    "Put the MIME part under point into a new buffer.
4195    If `auto-compression-mode' is enabled, compressed files like .gz and .bz2
4196    are decompressed."
4197    (interactive)    (interactive)
4198    (gnus-article-check-buffer)    (gnus-article-check-buffer)
4199    (let* ((handle (or handle (get-text-property (point) 'gnus-data)))    (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
4200           (contents (mm-get-part handle))           (contents (and handle (mm-get-part handle)))
4201           (base (file-name-nondirectory           (base (and handle
4202                  (or                      (file-name-nondirectory
4203                   (mail-content-type-get (mm-handle-type handle) 'name)                       (or
4204                   (mail-content-type-get (mm-handle-type handle)                        (mail-content-type-get (mm-handle-type handle) 'name)
4205                                          'filename)                        (mail-content-type-get (mm-handle-disposition handle)
4206                   "*decoded*")))                                               'filename)
4207           (buffer (generate-new-buffer base)))                        "*decoded*"))))
4208      (switch-to-buffer buffer)           (buffer (and base (generate-new-buffer base))))
4209      (insert contents)      (when contents
4210      ;; We do it this way to make `normal-mode' set the appropriate mode.        (switch-to-buffer buffer)
4211      (unwind-protect        (insert contents)
4212          (progn        ;; We do it this way to make `normal-mode' set the appropriate mode.
4213            (setq buffer-file-name (expand-file-name base))        (unwind-protect
4214            (normal-mode))            (progn
4215        (setq buffer-file-name nil))              (setq buffer-file-name (expand-file-name base))
4216      (goto-char (point-min))))              (gnus-mime-jka-compr-maybe-uncompress)
4217                (normal-mode))
4218            (setq buffer-file-name nil))
4219          (goto-char (point-min)))))
4220    
4221    (defun gnus-mime-print-part (&optional handle filename)
4222      "Print the MIME part under point."
4223      (interactive (list nil (ps-print-preprint current-prefix-arg)))
4224      (gnus-article-check-buffer)
4225      (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
4226             (contents (and handle (mm-get-part handle)))
4227             (file (mm-make-temp-file (expand-file-name "mm." mm-tmp-directory)))
4228             (printer (mailcap-mime-info (mm-handle-media-type handle) "print")))
4229        (when contents
4230            (if printer
4231                (unwind-protect
4232                    (progn
4233                      (mm-save-part-to-file handle file)
4234                      (call-process shell-file-name nil
4235                                    (generate-new-buffer " *mm*")
4236                                    nil
4237                                    shell-command-switch
4238                                    (mm-mailcap-command
4239                                     printer file (mm-handle-type handle))))
4240                  (delete-file file))
4241              (with-temp-buffer
4242                (insert contents)
4243                (gnus-print-buffer))
4244              (ps-despool filename)))))
4245    
4246  (defun gnus-mime-inline-part (&optional handle arg)  (defun gnus-mime-inline-part (&optional handle arg)
4247    "Insert the MIME part under point into the current buffer."    "Insert the MIME part under point into the current buffer."
# Line 3098  If ALL-HEADERS is non-nil, no headers ar Line 4250  If ALL-HEADERS is non-nil, no headers ar
4250    (let* ((handle (or handle (get-text-property (point) 'gnus-data)))    (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
4251           contents charset           contents charset
4252           (b (point))           (b (point))
4253           buffer-read-only)           (inhibit-read-only t))
4254      (if (mm-handle-undisplayer handle)      (when handle
4255          (mm-remove-part handle)        (if (and (not arg) (mm-handle-undisplayer handle))
4256        (setq contents (mm-get-part handle))            (mm-remove-part handle)
4257        (cond          (setq contents (mm-get-part handle))
4258         ((not arg)          (cond
4259          (setq charset (or (mail-content-type-get           ((not arg)
4260                             (mm-handle-type handle) 'charset)            (setq charset (or (mail-content-type-get
4261                            gnus-newsgroup-charset)))                               (mm-handle-type handle) 'charset)
4262         ((numberp arg)                              gnus-newsgroup-charset)))
4263          (setq charset           ((numberp arg)
4264                (or (cdr (assq arg            (if (mm-handle-undisplayer handle)
4265                               gnus-summary-show-article-charset-alist))                (mm-remove-part handle))
4266                    (read-coding-system "Charset: ")))))            (setq charset
4267        (forward-line 2)                  (or (cdr (assq arg
4268        (mm-insert-inline handle                                 gnus-summary-show-article-charset-alist))
4269                          (if (and charset                      (mm-read-coding-system "Charset: ")))))
4270                                   (setq charset (mm-charset-to-coding-system          (forward-line 2)
4271                                                  charset))          (mm-insert-inline handle
4272                                   (not (eq charset 'ascii)))                            (if (and charset
4273                              (mm-decode-coding-string contents charset)                                     (setq charset (mm-charset-to-coding-system
4274                            contents))                                                    charset))
4275        (goto-char b))))                                     (not (eq charset 'ascii)))
4276                                  (mm-decode-coding-string contents charset)
4277                                contents))
4278            (goto-char b)))))
4279    
4280    (defun gnus-mime-view-part-as-charset (&optional handle arg)
4281      "Insert the MIME part under point into the current buffer using the
4282    specified charset."
4283      (interactive (list nil current-prefix-arg))
4284      (gnus-article-check-buffer)
4285      (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
4286             contents charset
4287             (b (point))
4288             (inhibit-read-only t))
4289        (when handle
4290          (if (mm-handle-undisplayer handle)
4291              (mm-remove-part handle))
4292          (let ((gnus-newsgroup-charset
4293                 (or (cdr (assq arg
4294                                gnus-summary-show-article-charset-alist))
4295                     (mm-read-coding-system "Charset: ")))
4296              (gnus-newsgroup-ignored-charsets 'gnus-all))
4297            (gnus-article-press-button)))))
4298    
4299  (defun gnus-mime-externalize-part (&optional handle)  (defun gnus-mime-view-part-externally (&optional handle)
4300    "View the MIME part under point with an external viewer."    "View the MIME part under point with an external viewer."
4301    (interactive)    (interactive)
4302    (gnus-article-check-buffer)    (gnus-article-check-buffer)
# Line 3133  If ALL-HEADERS is non-nil, no headers ar Line 4307  If ALL-HEADERS is non-nil, no headers ar
4307           (mail-parse-ignored-charsets           (mail-parse-ignored-charsets
4308            (save-excursion (set-buffer gnus-summary-buffer)            (save-excursion (set-buffer gnus-summary-buffer)
4309                            gnus-newsgroup-ignored-charsets)))                            gnus-newsgroup-ignored-charsets)))
4310      (if (mm-handle-undisplayer handle)      (when handle
4311          (mm-remove-part handle)        (if (mm-handle-undisplayer handle)
4312        (mm-display-part handle))))            (mm-remove-part handle)
4313            (mm-display-part handle)))))
4314    
4315  (defun gnus-mime-internalize-part (&optional handle)  (defun gnus-mime-view-part-internally (&optional handle)
4316    "View the MIME part under point with an internal viewer.    "View the MIME part under point with an internal viewer.
4317  In no internal viewer is available, use an external viewer."  If no internal viewer is available, use an external viewer."
4318    (interactive)    (interactive)
4319    (gnus-article-check-buffer)    (gnus-article-check-buffer)
4320    (let* ((handle (or handle (get-text-property (point) 'gnus-data)))    (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
# Line 3148  In no internal viewer is available, use Line 4323  In no internal viewer is available, use
4323           (mail-parse-charset gnus-newsgroup-charset)           (mail-parse-charset gnus-newsgroup-charset)
4324           (mail-parse-ignored-charsets           (mail-parse-ignored-charsets
4325            (save-excursion (set-buffer gnus-summary-buffer)            (save-excursion (set-buffer gnus-summary-buffer)
4326                            gnus-newsgroup-ignored-charsets)))                            gnus-newsgroup-ignored-charsets))
4327      (if (mm-handle-undisplayer handle)           (inhibit-read-only t))
4328          (mm-remove-part handle)      (when handle
4329        (mm-display-part handle))))        (if (mm-handle-undisplayer handle)
4330              (mm-remove-part handle)
4331            (mm-display-part handle)))))
4332    
4333  (defun gnus-mime-action-on-part (&optional action)  (defun gnus-mime-action-on-part (&optional action)
4334    "Do something with the MIME attachment at \(point\)."    "Do something with the MIME attachment at \(point\)."
4335    (interactive    (interactive
4336     (list (completing-read "Action: " gnus-mime-action-alist)))     (list (completing-read "Action: " gnus-mime-action-alist nil t)))
4337    (gnus-article-check-buffer)    (gnus-article-check-buffer)
4338    (let ((action-pair (assoc action gnus-mime-action-alist)))    (let ((action-pair (assoc action gnus-mime-action-alist)))
4339      (if action-pair      (if action-pair
4340          (funcall (cdr action-pair)))))          (funcall (cdr action-pair)))))
4341    
   
4342  (defun gnus-article-part-wrapper (n function)  (defun gnus-article-part-wrapper (n function)
4343    (save-current-buffer    (save-current-buffer
4344      (set-buffer gnus-article-buffer)      (set-buffer gnus-article-buffer)
# Line 3192  In no internal viewer is available, use Line 4368  In no internal viewer is available, use
4368    (interactive "p")    (interactive "p")
4369    (gnus-article-part-wrapper n 'gnus-mime-copy-part))    (gnus-article-part-wrapper n 'gnus-mime-copy-part))
4370    
4371  (defun gnus-article-externalize-part (n)  (defun gnus-article-view-part-as-charset (n)
4372      "View MIME part N using a specified charset.
4373    N is the numerical prefix."
4374      (interactive "p")
4375      (gnus-article-part-wrapper n 'gnus-mime-view-part-as-charset))
4376    
4377    (defun gnus-article-view-part-externally (n)
4378    "View MIME part N externally, which is the numerical prefix."    "View MIME part N externally, which is the numerical prefix."
4379    (interactive "p")    (interactive "p")
4380    (gnus-article-part-wrapper n 'gnus-mime-externalize-part))    (gnus-article-part-wrapper n 'gnus-mime-view-part-externally))
4381    
4382  (defun gnus-article-inline-part (n)  (defun gnus-article-inline-part (n)
4383    "Inline MIME part N, which is the numerical prefix."    "Inline MIME part N, which is the numerical prefix."
# Line 3247  In no internal viewer is available, use Line 4429  In no internal viewer is available, use
4429    "Display HANDLE and fix MIME button."    "Display HANDLE and fix MIME button."
4430    (let ((id (get-text-property (point) 'gnus-part))    (let ((id (get-text-property (point) 'gnus-part))
4431          (point (point))          (point (point))
4432          buffer-read-only)          (inhibit-read-only t))
4433      (forward-line 1)      (forward-line 1)
4434      (prog1      (prog1
4435          (let ((window (selected-window))          (let ((window (selected-window))
4436                (mail-parse-charset gnus-newsgroup-charset)                (mail-parse-charset gnus-newsgroup-charset)
4437                (mail-parse-ignored-charsets                (mail-parse-ignored-charsets
4438                 (save-excursion (set-buffer gnus-summary-buffer)                 (if (gnus-buffer-live-p gnus-summary-buffer)
4439                                 gnus-newsgroup-ignored-charsets)))                     (save-excursion
4440                         (set-buffer gnus-summary-buffer)
4441                         gnus-newsgroup-ignored-charsets)
4442                     nil)))
4443            (save-excursion            (save-excursion
4444              (unwind-protect              (unwind-protect
4445                  (let ((win (get-buffer-window (current-buffer) t))                  (let ((win (gnus-get-buffer-window (current-buffer) t))
4446                        (beg (point)))                        (beg (point)))
4447                    (when win                    (when win
4448                      (select-window win))                      (select-window win))
# Line 3267  In no internal viewer is available, use Line 4452  In no internal viewer is available, use
4452                        ;; This will remove the part.                        ;; This will remove the part.
4453                        (mm-display-part handle)                        (mm-display-part handle)
4454                      (save-restriction                      (save-restriction
4455                        (narrow-to-region (point) (1+ (point)))                        (narrow-to-region (point)
4456                                            (if (eobp) (point) (1+ (point))))
4457                        (mm-display-part handle)                        (mm-display-part handle)
4458                        ;; We narrow to the part itself and                        ;; We narrow to the part itself and
4459                        ;; then call the treatment functions.                        ;; then call the treatment functions.
# Line 3278  In no internal viewer is available, use Line 4464  In no internal viewer is available, use
4464                         nil id                         nil id
4465                         (gnus-article-mime-total-parts)                         (gnus-article-mime-total-parts)
4466                         (mm-handle-media-type handle)))))                         (mm-handle-media-type handle)))))
4467                (select-window window))))                (if (window-live-p window)
4468                      (select-window window)))))
4469        (goto-char point)        (goto-char point)
4470        (delete-region (gnus-point-at-bol) (progn (forward-line 1) (point)))        (gnus-delete-line)
4471        (gnus-insert-mime-button        (gnus-insert-mime-button
4472         handle id (list (mm-handle-displayed-p handle)))         handle id (list (mm-handle-displayed-p handle)))
4473        (goto-char point))))        (goto-char point))))
4474    
4475  (defun gnus-article-goto-part (n)  (defun gnus-article-goto-part (n)
4476    "Go to MIME part N."    "Go to MIME part N."
4477    (let ((point (text-property-any (point-min) (point-max) 'gnus-part n)))    (gnus-goto-char (text-property-any (point-min) (point-max) 'gnus-part n)))
     (when point  
       (goto-char point))))  
4478    
4479  (defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed)  (defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed)
4480    (let ((gnus-tmp-name    (let ((gnus-tmp-name
4481           (or (mail-content-type-get (mm-handle-type handle)           (or (mail-content-type-get (mm-handle-type handle) 'name)
4482                                      'name)               (mail-content-type-get (mm-handle-disposition handle) 'filename)
4483               (mail-content-type-get (mm-handle-disposition handle)               (mail-content-type-get (mm-handle-type handle) 'url)
                                     'filename)  
4484               ""))               ""))
4485          (gnus-tmp-type (mm-handle-media-type handle))          (gnus-tmp-type (mm-handle-media-type handle))
4486          (gnus-tmp-description          (gnus-tmp-description
# Line 3314  In no internal viewer is available, use Line 4498  In no internal viewer is available, use
4498      (setq gnus-tmp-type-long (concat gnus-tmp-type      (setq gnus-tmp-type-long (concat gnus-tmp-type
4499                                       (and (not (equal gnus-tmp-name ""))                                       (and (not (equal gnus-tmp-name ""))
4500                                            (concat "; " gnus-tmp-name))))                                            (concat "; " gnus-tmp-name))))
4501      (or (equal gnus-tmp-description "")      (unless (equal gnus-tmp-description "")
4502          (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long)))        (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long)))
4503      (unless (bolp)      (unless (bolp)
4504        (insert "\n"))        (insert "\n"))
4505      (setq b (point))      (setq b (point))
4506      (gnus-eval-format      (gnus-eval-format
4507       gnus-mime-button-line-format gnus-mime-button-line-format-alist       gnus-mime-button-line-format gnus-mime-button-line-format-alist
4508       `(keymap ,gnus-mime-button-map       `(,@(gnus-local-map-property gnus-mime-button-map)
4509         ;; Not for Emacs 21: fixme better.           gnus-callback gnus-mm-display-part
4510         ;; local-map ,gnus-mime-button-map           gnus-part ,gnus-tmp-id
4511         gnus-callback gnus-mm-display-part           article-type annotation
4512         gnus-part ,gnus-tmp-id           gnus-data ,handle))
4513         article-type annotation      (setq e (if (bolp)
4514         gnus-data ,handle))                  ;; Exclude a newline.
4515      (setq e (point))                  (1- (point))
4516                  (point)))
4517      (widget-convert-button      (widget-convert-button
4518       'link b e       'link b e
4519       :mime-handle handle       :mime-handle handle
# Line 3371  In no internal viewer is available, use Line 4556  In no internal viewer is available, use
4556            ;; We have to do this since selecting the window            ;; We have to do this since selecting the window
4557            ;; may change the point.  So we set the window point.            ;; may change the point.  So we set the window point.
4558            (set-window-point window point)))            (set-window-point window point)))
4559        (let* ((handles (or ihandles (mm-dissect-buffer) (mm-uu-dissect)))        (let* ((handles (or ihandles
4560               buffer-read-only handle name type b e display)                            (mm-dissect-buffer nil gnus-article-loose-mime)
4561                              (and gnus-article-emulate-mime
4562                                   (mm-uu-dissect))))
4563                 (inhibit-read-only t) handle name type b e display)
4564          (when (and (not ihandles)          (when (and (not ihandles)
4565                     (not gnus-displaying-mime))                     (not gnus-displaying-mime))
4566            ;; Top-level call; we clean up.            ;; Top-level call; we clean up.
# Line 3407  In no internal viewer is available, use Line 4595  In no internal viewer is available, use
4595                (narrow-to-region (point-min) (point))                (narrow-to-region (point-min) (point))
4596                (gnus-treat-article 'head))))))))                (gnus-treat-article 'head))))))))
4597    
4598  (defvar gnus-mime-display-multipart-as-mixed nil)  (defcustom gnus-mime-display-multipart-as-mixed nil
4599      "Display \"multipart\" parts as  \"multipart/mixed\".
4600    
4601    If t, it overrides nil values of
4602    `gnus-mime-display-multipart-alternative-as-mixed' and
4603    `gnus-mime-display-multipart-related-as-mixed'."
4604      :group 'gnus-article-mime
4605      :type 'boolean)
4606    
4607    (defcustom gnus-mime-display-multipart-alternative-as-mixed nil
4608      "Display \"multipart/alternative\" parts as  \"multipart/mixed\"."
4609      :group 'gnus-article-mime
4610      :type 'boolean)
4611    
4612    (defcustom gnus-mime-display-multipart-related-as-mixed nil
4613      "Display \"multipart/related\" parts as  \"multipart/mixed\".
4614    
4615    If displaying \"text/html\" is discouraged \(see
4616    `mm-discouraged-alternatives'\) images or other material inside a
4617    \"multipart/related\" part might be overlooked when this variable is nil."
4618      :group 'gnus-article-mime
4619      :type 'boolean)
4620    
4621  (defun gnus-mime-display-part (handle)  (defun gnus-mime-display-part (handle)
4622    (cond    (cond
# Line 3420  In no internal viewer is available, use Line 4629  In no internal viewer is available, use
4629               handle))               handle))
4630     ;; multipart/alternative     ;; multipart/alternative
4631     ((and (equal (car handle) "multipart/alternative")     ((and (equal (car handle) "multipart/alternative")
4632           (not gnus-mime-display-multipart-as-mixed))           (not (or gnus-mime-display-multipart-as-mixed
4633                      gnus-mime-display-multipart-alternative-as-mixed)))
4634      (let ((id (1+ (length gnus-article-mime-handle-alist))))      (let ((id (1+ (length gnus-article-mime-handle-alist))))
4635        (push (cons id handle) gnus-article-mime-handle-alist)        (push (cons id handle) gnus-article-mime-handle-alist)
4636        (gnus-mime-display-alternative (cdr handle) nil nil id)))        (gnus-mime-display-alternative (cdr handle) nil nil id)))
4637     ;; multipart/related     ;; multipart/related
4638     ((and (equal (car handle) "multipart/related")     ((and (equal (car handle) "multipart/related")
4639           (not gnus-mime-display-multipart-as-mixed))           (not (or gnus-mime-display-multipart-as-mixed
4640                      gnus-mime-display-multipart-related-as-mixed)))
4641      ;;;!!!We should find the start part, but we just default      ;;;!!!We should find the start part, but we just default
4642      ;;;!!!to the first part.      ;;;!!!to the first part.
4643        ;;(gnus-mime-display-part (cadr handle))
4644        ;;;!!! Most multipart/related is an HTML message plus images.
4645        ;;;!!! Unfortunately we are unable to let W3 display those
4646        ;;;!!! included images, so we just display it as a mixed multipart.
4647        ;;(gnus-mime-display-mixed (cdr handle))
4648        ;;;!!! No, w3 can display everything just fine.
4649      (gnus-mime-display-part (cadr handle)))      (gnus-mime-display-part (cadr handle)))
4650       ((equal (car handle) "multipart/signed")
4651        (gnus-add-wash-type 'signed)
4652        (gnus-mime-display-security handle))
4653       ((equal (car handle) "multipart/encrypted")
4654        (gnus-add-wash-type 'encrypted)
4655        (gnus-mime-display-security handle))
4656     ;; Other multiparts are handled like multipart/mixed.     ;; Other multiparts are handled like multipart/mixed.
4657     (t     (t
4658      (gnus-mime-display-mixed (cdr handle)))))      (gnus-mime-display-mixed (cdr handle)))))
# Line 3460  In no internal viewer is available, use Line 4683  In no internal viewer is available, use
4683                                         "inline")                                         "inline")
4684                                  (mm-attachment-override-p handle))))                                  (mm-attachment-override-p handle))))
4685                   (mm-automatic-display-p handle)                   (mm-automatic-display-p handle)
4686                   (or (mm-inlined-p handle)                   (or (and
4687                          (mm-inlinable-p handle)
4688                          (mm-inlined-p handle))
4689                       (mm-automatic-external-display-p type)))                       (mm-automatic-external-display-p type)))
4690              (setq display t)              (setq display t)
4691            (when (equal (mm-handle-media-supertype handle) "text")            (when (equal (mm-handle-media-supertype handle) "text")
# Line 3475  In no internal viewer is available, use Line 4700  In no internal viewer is available, use
4700               handle id (list (or display (and not-attachment text))))               handle id (list (or display (and not-attachment text))))
4701              (gnus-article-insert-newline)              (gnus-article-insert-newline)
4702              ;(gnus-article-insert-newline)              ;(gnus-article-insert-newline)
4703                ;; Remember modify the number of forward lines.
4704              (setq move t))              (setq move t))
4705            (setq beg (point))            (setq beg (point))
4706            (cond            (cond
4707             (display             (display
4708              (when move              (when move
4709                (forward-line -2)                (forward-line -1)
4710                (setq beg (point)))                (setq beg (point)))
4711              (let ((mail-parse-charset gnus-newsgroup-charset)              (let ((mail-parse-charset gnus-newsgroup-charset)
4712                    (mail-parse-ignored-charsets                    (mail-parse-ignored-charsets
# Line 3492  In no internal viewer is available, use Line 4718  In no internal viewer is available, use
4718              (goto-char (point-max)))              (goto-char (point-max)))
4719             ((and text not-attachment)             ((and text not-attachment)
4720              (when move              (when move
4721                (forward-line -2)                (forward-line -1)
4722                (setq beg (point)))                (setq beg (point)))
4723              (gnus-article-insert-newline)              (gnus-article-insert-newline)
4724              (mm-insert-inline handle (mm-get-part handle))              (mm-insert-inline handle (mm-get-part handle))
# Line 3509  In no internal viewer is available, use Line 4735  In no internal viewer is available, use
4735  (defun gnus-unbuttonized-mime-type-p (type)  (defun gnus-unbuttonized-mime-type-p (type)
4736    "Say whether TYPE is to be unbuttonized."    "Say whether TYPE is to be unbuttonized."
4737    (unless gnus-inhibit-mime-unbuttonizing    (unless gnus-inhibit-mime-unbuttonizing
4738      (catch 'found      (when (catch 'found
4739        (let ((types gnus-unbuttonized-mime-types))              (let ((types gnus-unbuttonized-mime-types))
4740          (while types                (while types
4741            (when (string-match (pop types) type)                  (when (string-match (pop types) type)
4742              (throw 'found t)))))))                    (throw 'found t)))))
4743          (not (catch 'found
4744                 (let ((types gnus-buttonized-mime-types))
4745                   (while types
4746                     (when (string-match (pop types) type)
4747                       (throw 'found t)))))))))
4748    
4749  (defun gnus-article-insert-newline ()  (defun gnus-article-insert-newline ()
4750    "Insert a newline, but mark it as undeletable."    "Insert a newline, but mark it as undeletable."
# Line 3524  In no internal viewer is available, use Line 4755  In no internal viewer is available, use
4755    (let* ((preferred (or preferred (mm-preferred-alternative handles)))    (let* ((preferred (or preferred (mm-preferred-alternative handles)))
4756           (ihandles handles)           (ihandles handles)
4757           (point (point))           (point (point))
4758           handle buffer-read-only from props begend not-pref)           handle (inhibit-read-only t) from props begend not-pref)
4759      (save-window-excursion      (save-window-excursion
4760        (save-restriction        (save-restriction
4761          (when ibegend          (when ibegend
# Line 3541  In no internal viewer is available, use Line 4772  In no internal viewer is available, use
4772          (unless (setq not-pref (cadr (member preferred ihandles)))          (unless (setq not-pref (cadr (member preferred ihandles)))
4773            (setq not-pref (car ihandles)))            (setq not-pref (car ihandles)))
4774          (when (or ibegend          (when (or ibegend
4775                      (not preferred)
4776                    (not (gnus-unbuttonized-mime-type-p                    (not (gnus-unbuttonized-mime-type-p
4777                          "multipart/alternative")))                          "multipart/alternative")))
4778            (gnus-add-text-properties            (gnus-add-text-properties
# Line 3555  In no internal viewer is available, use Line 4787  In no internal viewer is available, use
4787                         ',gnus-article-mime-handle-alist))                         ',gnus-article-mime-handle-alist))
4788                 (gnus-mime-display-alternative                 (gnus-mime-display-alternative
4789                  ',ihandles ',not-pref ',begend ,id))                  ',ihandles ',not-pref ',begend ,id))
4790               ;; Not for Emacs 21: fixme better.               ,@(gnus-local-map-property gnus-mime-button-map)
              ;; local-map ,gnus-mime-button-map  
4791               ,gnus-mouse-face-prop ,gnus-article-mouse-face               ,gnus-mouse-face-prop ,gnus-article-mouse-face
4792               face ,gnus-article-button-face               face ,gnus-article-button-face
              keymap ,gnus-mime-button-map  
4793               gnus-part ,id               gnus-part ,id
4794               gnus-data ,handle))               gnus-data ,handle))
4795            (widget-convert-button 'link from (point)            (widget-convert-button 'link from (point)
# Line 3581  In no internal viewer is available, use Line 4811  In no internal viewer is available, use
4811                           ',gnus-article-mime-handle-alist))                           ',gnus-article-mime-handle-alist))
4812                   (gnus-mime-display-alternative                   (gnus-mime-display-alternative
4813                    ',ihandles ',handle ',begend ,id))                    ',ihandles ',handle ',begend ,id))
4814                 ;; Not for Emacs 21: fixme better.                 ,@(gnus-local-map-property gnus-mime-button-map)
                ;; local-map ,gnus-mime-button-map  
4815                 ,gnus-mouse-face-prop ,gnus-article-mouse-face                 ,gnus-mouse-face-prop ,gnus-article-mouse-face
4816                 face ,gnus-article-button-face                 face ,gnus-article-button-face
                keymap ,gnus-mime-button-map  
4817                 gnus-part ,id                 gnus-part ,id
4818                 gnus-data ,handle))                 gnus-data ,handle))
4819              (widget-convert-button 'link from (point)              (widget-convert-button 'link from (point)
# Line 3614  In no internal viewer is available, use Line 4842  In no internal viewer is available, use
4842      (when ibegend      (when ibegend
4843        (goto-char point))))        (goto-char point))))
4844    
4845    (defconst gnus-article-wash-status-strings
4846      (let ((alist '((cite "c" "Possible hidden citation text"
4847                           " " "All citation text visible")
4848                     (headers "h" "Hidden headers"
4849                              " " "All headers visible.")
4850                     (pgp "p" "Encrypted or signed message status hidden"
4851                          " " "No hidden encryption nor digital signature status")
4852                     (signature "s" "Signature has been hidden"
4853                                " " "Signature is visible")
4854                     (overstrike "o" "Overstrike (^H) characters applied"
4855                                 " " "No overstrike characters applied")
4856                     (emphasis "e" "/*_Emphasis_*/ characters applied"
4857                               " " "No /*_emphasis_*/ characters applied")))
4858            result)
4859        (dolist (entry alist result)
4860          (let ((key (nth 0 entry))
4861                (on (copy-sequence (nth 1 entry)))
4862                (on-help (nth 2 entry))
4863                (off (copy-sequence (nth 3 entry)))
4864                (off-help (nth 4 entry)))
4865            (put-text-property 0 1 'help-echo on-help on)
4866            (put-text-property 0 1 'help-echo off-help off)
4867            (push (list key on off) result))))
4868      "Alist of strings describing wash status in the mode line.
4869    Each entry has the form (KEY ON OF), where the KEY is a symbol
4870    representing the particular washing function, ON is the string to use
4871    in the article mode line when the washing function is active, and OFF
4872    is the string to use when it is inactive.")
4873    
4874    (defun gnus-article-wash-status-entry (key value)
4875      (let ((entry (assoc key gnus-article-wash-status-strings)))
4876        (if value (nth 1 entry) (nth 2 entry))))
4877    
4878  (defun gnus-article-wash-status ()  (defun gnus-article-wash-status ()
4879    "Return a string which display status of article washing."    "Return a string which display status of article washing."
4880    (save-excursion    (save-excursion
# Line 3623  In no internal viewer is available, use Line 4884  In no internal viewer is available, use
4884            (boring (memq 'boring-headers gnus-article-wash-types))            (boring (memq 'boring-headers gnus-article-wash-types))
4885            (pgp (memq 'pgp gnus-article-wash-types))            (pgp (memq 'pgp gnus-article-wash-types))
4886            (pem (memq 'pem gnus-article-wash-types))            (pem (memq 'pem gnus-article-wash-types))
4887              (signed (memq 'signed gnus-article-wash-types))
4888              (encrypted (memq 'encrypted gnus-article-wash-types))
4889            (signature (memq 'signature gnus-article-wash-types))            (signature (memq 'signature gnus-article-wash-types))
4890            (overstrike (memq 'overstrike gnus-article-wash-types))            (overstrike (memq 'overstrike gnus-article-wash-types))
4891            (emphasis (memq 'emphasis gnus-article-wash-types)))            (emphasis (memq 'emphasis gnus-article-wash-types)))
4892        (format "%c%c%c%c%c%c"        (concat
4893                (if cite ?c ? )         (gnus-article-wash-status-entry 'cite cite)
4894                (if (or headers boring) ?h ? )         (gnus-article-wash-status-entry 'headers (or headers boring))
4895                (if (or pgp pem) ?p ? )         (gnus-article-wash-status-entry 'pgp (or pgp pem signed encrypted))
4896                (if signature ?s ? )         (gnus-article-wash-status-entry 'signature signature)
4897                (if overstrike ?o ? )         (gnus-article-wash-status-entry 'overstrike overstrike)
4898                (if emphasis ?e ? )))))         (gnus-article-wash-status-entry 'emphasis emphasis)))))
4899    
4900    (defun gnus-add-wash-type (type)
4901      "Add a washing of TYPE to the current status."
4902      (add-to-list 'gnus-article-wash-types type))
4903    
4904    (defun gnus-delete-wash-type (type)
4905      "Add a washing of TYPE to the current status."
4906      (setq gnus-article-wash-types (delq type gnus-article-wash-types)))
4907    
4908    (defun gnus-add-image (category image)
4909      "Add IMAGE of CATEGORY to the list of displayed images."
4910      (let ((entry (assq category gnus-article-image-alist)))
4911        (unless entry
4912          (setq entry (list category))
4913          (push entry gnus-article-image-alist))
4914        (nconc entry (list image))))
4915    
4916    (defun gnus-delete-images (category)
4917      "Delete all images in CATEGORY."
4918      (let ((entry (assq category gnus-article-image-alist)))
4919        (dolist (image (cdr entry))
4920          (gnus-remove-image image category))
4921        (setq gnus-article-image-alist (delq entry gnus-article-image-alist))
4922        (gnus-delete-wash-type category)))
4923    
4924  (defalias 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers)  (defalias 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers)
4925    
# Line 3674  If given a numerical ARG, move forward A Line 4961  If given a numerical ARG, move forward A
4961        (let ((inhibit-read-only t))        (let ((inhibit-read-only t))
4962          (gnus-remove-text-with-property 'gnus-prev)          (gnus-remove-text-with-property 'gnus-prev)
4963          (gnus-remove-text-with-property 'gnus-next)))          (gnus-remove-text-with-property 'gnus-next)))
4964      (when      (if
4965          (cond ((< arg 0)          (cond ((< arg 0)
4966                 (re-search-backward page-delimiter nil 'move (1+ (abs arg))))                 (re-search-backward page-delimiter nil 'move (1+ (abs arg))))
4967                ((> arg 0)                ((> arg 0)
4968                 (re-search-forward page-delimiter nil 'move arg)))                 (re-search-forward page-delimiter nil 'move arg)))
4969        (goto-char (match-end 0)))          (goto-char (match-end 0))
     (narrow-to-region  
      (point)  
      (if (re-search-forward page-delimiter nil 'move)  
          (match-beginning 0)  
        (point)))  
     (when (and (gnus-visual-p 'page-marker)  
                (> (point-min) (save-restriction (widen) (point-min))))  
4970        (save-excursion        (save-excursion
4971          (goto-char (point-min))          (goto-char (point-min))
4972          (gnus-insert-prev-page-button)))          (setq gnus-page-broken
4973      (when (and (gnus-visual-p 'page-marker)                (and (re-search-forward page-delimiter nil t) t))))
4974                 (< (point-max) (save-restriction (widen) (point-max))))      (when gnus-page-broken
4975        (save-excursion        (narrow-to-region
4976          (goto-char (point-max))         (point)
4977          (gnus-insert-next-page-button)))))         (if (re-search-forward page-delimiter nil 'move)
4978               (match-beginning 0)
4979             (point)))
4980          (when (and (gnus-visual-p 'page-marker)
4981                     (> (point-min) (save-restriction (widen) (point-min))))
4982            (save-excursion
4983              (goto-char (point-min))
4984              (gnus-insert-prev-page-button)))
4985          (when (and (gnus-visual-p 'page-marker)
4986                     (< (+ (point-max) 2) (buffer-size)))
4987            (save-excursion
4988              (goto-char (point-max))
4989              (gnus-insert-next-page-button))))))
4990    
4991  ;; Article mode commands  ;; Article mode commands
4992    
# Line 3705  If given a numerical ARG, move forward A Line 4997  If given a numerical ARG, move forward A
4997      (goto-char (point-min))      (goto-char (point-min))
4998      (gnus-article-read-summary-keys nil (gnus-character-to-event ?n))))      (gnus-article-read-summary-keys nil (gnus-character-to-event ?n))))
4999    
5000    
5001  (defun gnus-article-goto-prev-page ()  (defun gnus-article-goto-prev-page ()
5002    "Show the next page of the article."    "Show the previous page of the article."
5003    (interactive)    (interactive)
5004    (if (bobp) (gnus-article-read-summary-keys nil (gnus-character-to-event ?p))    (if (bobp)
5005          (gnus-article-read-summary-keys nil (gnus-character-to-event ?p))
5006      (gnus-article-prev-page nil)))      (gnus-article-prev-page nil)))
5007    
5008    ;; This is cleaner but currently breaks `gnus-pick-mode':
5009    ;;
5010    ;; (defun gnus-article-goto-next-page ()
5011    ;;   "Show the next page of the article."
5012    ;;   (interactive)
5013    ;;   (gnus-eval-in-buffer-window gnus-summary-buffer
5014    ;;     (gnus-summary-next-page)))
5015    ;;
5016    ;; (defun gnus-article-goto-prev-page ()
5017    ;;   "Show the next page of the article."
5018    ;;   (interactive)
5019    ;;   (gnus-eval-in-buffer-window gnus-summary-buffer
5020    ;;     (gnus-summary-prev-page)))
5021    
5022  (defun gnus-article-next-page (&optional lines)  (defun gnus-article-next-page (&optional lines)
5023    "Show the next page of the current article.    "Show the next page of the current article.
5024  If end of article, return non-nil.  Otherwise return nil.  If end of article, return non-nil.  Otherwise return nil.
# Line 3720  Argument LINES specifies lines to be scr Line 5028  Argument LINES specifies lines to be scr
5028    (if (save-excursion    (if (save-excursion
5029          (end-of-line)          (end-of-line)
5030          (and (pos-visible-in-window-p)  ;Not continuation line.          (and (pos-visible-in-window-p)  ;Not continuation line.
5031               (eobp)))               (>= (1+ (point)) (point-max)))) ;Allow for trailing newline.
5032        ;; Nothing in this page.        ;; Nothing in this page.
5033        (if (or (not gnus-page-broken)        (if (or (not gnus-page-broken)
5034                (save-excursion                (save-excursion
5035                  (save-restriction                  (save-restriction
5036                    (widen) (forward-line 1) (eobp)))) ;Real end-of-buffer?                    (widen)
5037            t                             ;Nothing more.                    (forward-line)
5038                      (eobp)))) ;Real end-of-buffer?
5039              (progn
5040                (when gnus-article-over-scroll
5041                  (gnus-article-next-page-1 lines))
5042                t)                  ;Nothing more.
5043          (gnus-narrow-to-page 1)         ;Go to next page.          (gnus-narrow-to-page 1)         ;Go to next page.
5044          nil)          nil)
5045      ;; More in this page.      ;; More in this page.
5046      (let ((scroll-in-place nil))      (gnus-article-next-page-1 lines)
       (condition-case ()  
           (scroll-up lines)  
         (end-of-buffer  
          ;; Long lines may cause an end-of-buffer error.  
          (goto-char (point-max)))))  
     (move-to-window-line 0)  
5047      nil))      nil))
5048    
5049    (defun gnus-article-next-page-1 (lines)
5050      (let ((scroll-in-place nil))
5051        (condition-case ()
5052            (scroll-up lines)
5053          (end-of-buffer
5054           ;; Long lines may cause an end-of-buffer error.
5055           (goto-char (point-max)))))
5056      (move-to-window-line 0))
5057    
5058  (defun gnus-article-prev-page (&optional lines)  (defun gnus-article-prev-page (&optional lines)
5059    "Show previous page of current article.    "Show previous page of current article.
5060  Argument LINES specifies lines to be scrolled down."  Argument LINES specifies lines to be scrolled down."
# Line 3759  Argument LINES specifies lines to be scr Line 5075  Argument LINES specifies lines to be scr
5075               (goto-char (point-min))))               (goto-char (point-min))))
5076          (move-to-window-line 0)))))          (move-to-window-line 0)))))
5077    
5078    (defun gnus-article-only-boring-p ()
5079      "Decide whether there is only boring text remaining in the article.
5080    Something \"interesting\" is a word of at least two letters that does
5081    not have a face in `gnus-article-boring-faces'."
5082      (when (and gnus-article-skip-boring
5083                 (boundp 'gnus-article-boring-faces)
5084                 (symbol-value 'gnus-article-boring-faces))
5085        (save-excursion
5086          (catch 'only-boring
5087            (while (re-search-forward "\\b\\w\\w" nil t)
5088              (forward-char -1)
5089              (when (not (gnus-intersection
5090                          (gnus-faces-at (point))
5091                          (symbol-value 'gnus-article-boring-faces)))
5092                (throw 'only-boring nil)))
5093            (throw 'only-boring t)))))
5094    
5095  (defun gnus-article-refer-article ()  (defun gnus-article-refer-article ()
5096    "Read article specified by message-id around point."    "Read article specified by message-id around point."
5097    (interactive)    (interactive)
5098    (let ((point (point)))    (save-excursion
5099      (search-forward ">" nil t)          ;Move point to end of "<....>".      (re-search-backward "[ \t]\\|^" (gnus-point-at-bol) t)
5100      (if (re-search-backward "\\(<[^<> \t\n]+>\\)" nil t)      (re-search-forward "<?news:<?\\|<" (gnus-point-at-eol) t)
5101          (let ((message-id (match-string 1)))      (if (re-search-forward "[^@ ]+@[^ \t>]+" (gnus-point-at-eol) t)
5102            (goto-char point)          (let ((msg-id (concat "<" (match-string 0) ">")))
5103            (set-buffer gnus-summary-buffer)            (set-buffer gnus-summary-buffer)
5104            (gnus-summary-refer-article message-id))            (gnus-summary-refer-article msg-id))
       (goto-char (point))  
5105        (error "No references around point"))))        (error "No references around point"))))
5106    
5107  (defun gnus-article-show-summary ()  (defun gnus-article-show-summary ()
# Line 3818  Argument LINES specifies lines to be scr Line 5150  Argument LINES specifies lines to be scr
5150    (interactive "P")    (interactive "P")
5151    (gnus-article-check-buffer)    (gnus-article-check-buffer)
5152    (let ((nosaves    (let ((nosaves
5153           '("q" "Q"  "c" "r" "R" "\C-c\C-f" "m"  "a" "f" "F"           '("q" "Q"  "c" "r" "\C-c\C-f" "m"  "a" "f"
5154             "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"             "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"
5155             "=" "^" "\M-^" "|"))             "=" "^" "\M-^" "|"))
5156          (nosave-but-article          (nosave-but-article
5157           '("A\r"))           '("A\r"))
5158          (nosave-in-article          (nosave-in-article
5159           '("\C-d"))           '("\C-d"))
5160          (up-to-top          (up-to-top
5161           '("n" "Gn" "p" "Gp"))           '("n" "Gn" "p" "Gp"))
5162          keys new-sum-point)          keys new-sum-point)
5163      (save-excursion      (save-excursion
5164        (set-buffer gnus-article-current-summary)        (set-buffer gnus-article-current-summary)
5165        (let (gnus-pick-mode)        (let (gnus-pick-mode)
5166          (push (or key last-command-event) unread-command-events)          (push (or key last-command-event) unread-command-events)
5167          (setq keys (if (featurep 'xemacs)          (setq keys (if (featurep 'xemacs)
5168                         (events-to-keys (read-key-sequence nil))                         (events-to-keys (read-key-sequence nil))
5169                       (read-key-sequence nil)))))                       (read-key-sequence nil)))))
5170    
5171      (message "")      (message "")
5172    
5173      (if (or (member keys nosaves)      (if (or (member keys nosaves)
5174              (member keys nosave-but-article)              (member keys nosave-but-article)
5175              (member keys nosave-in-article))              (member keys nosave-in-article))
5176          (let (func)          (let (func)
5177            (save-window-excursion            (save-window-excursion
5178              (pop-to-buffer gnus-article-current-summary 'norecord)              (pop-to-buffer gnus-article-current-summary 'norecord)
5179              ;; We disable the pick minor mode commands.              ;; We disable the pick minor mode commands.
5180              (let (gnus-pick-mode)              (let (gnus-pick-mode)
5181                (setq func (lookup-key (current-local-map) keys))))                (setq func (lookup-key (current-local-map) keys))))
5182            (if (or (not func)            (if (or (not func)
5183                    (numberp func))                    (numberp func))
5184                (ding)                (ding)
5185              (unless (member keys nosave-in-article)              (unless (member keys nosave-in-article)
5186                (set-buffer gnus-article-current-summary))                (set-buffer gnus-article-current-summary))
5187              (call-interactively func)              (call-interactively func)
5188              (setq new-sum-point (point)))              (setq new-sum-point (point)))
5189            (when (member keys nosave-but-article)            (when (member keys nosave-but-article)
5190              (pop-to-buffer gnus-article-buffer 'norecord)))              (pop-to-buffer gnus-article-buffer 'norecord)))
5191        ;; These commands should restore window configuration.        ;; These commands should restore window configuration.
5192        (let ((obuf (current-buffer))        (let ((obuf (current-buffer))
5193              (owin (current-window-configuration))              (owin (current-window-configuration))
5194              (opoint (point))              (opoint (point))
5195              (summary gnus-article-current-summary)              win func in-buffer selected new-sum-start new-sum-hscroll)
5196              func in-buffer selected)          (cond (not-restore-window
5197          (if not-restore-window                 (pop-to-buffer gnus-article-current-summary 'norecord))
5198              (pop-to-buffer summary 'norecord)                ((setq win (get-buffer-window gnus-article-current-summary))
5199            (switch-to-buffer summary 'norecord))                 (select-window win))
5200          (setq in-buffer (current-buffer))                (t
5201          ;; We disable the pick minor mode commands.                 (switch-to-buffer gnus-article-current-summary 'norecord)))
5202          (if (and (setq func (let (gnus-pick-mode)          (setq in-buffer (current-buffer))
5203            ;; We disable the pick minor mode commands.
5204            (if (and (setq func (let (gnus-pick-mode)
5205                                (lookup-key (current-local-map) keys)))                                (lookup-key (current-local-map) keys)))
5206                   (functionp func))                   (functionp func))
5207              (progn              (progn
5208                (call-interactively func)                (call-interactively func)
5209                (setq new-sum-point (point))                (when (eq win (selected-window))
5210                    (setq new-sum-point (point)
5211                          new-sum-start (window-start win)
5212                          new-sum-hscroll (window-hscroll win))
5213                (when (eq in-buffer (current-buffer))                (when (eq in-buffer (current-buffer))
5214                  (setq selected (gnus-summary-select-article))                  (setq selected (gnus-summary-select-article))
5215                  (set-buffer obuf)                  (set-buffer obuf)
# Line 3884  Argument LINES specifies lines to be scr Line 5221  Argument LINES specifies lines to be scr
5221                                      1)                                      1)
5222                    (set-window-point (get-buffer-window (current-buffer))                    (set-window-point (get-buffer-window (current-buffer))
5223                                      (point)))                                      (point)))
5224                  (let ((win (get-buffer-window gnus-article-current-summary)))                  (when (and (not not-restore-window)
5225                    (when win                             new-sum-point)
5226                      (set-window-point win new-sum-point))))    )                    (set-window-point win new-sum-point)
5227            (switch-to-buffer gnus-article-buffer)                    (set-window-start win new-sum-start)
5228            (ding))))))                    (set-window-hscroll win new-sum-hscroll)))))
5229              (set-window-configuration owin)
5230              (ding))))))
5231    
5232  (defun gnus-article-describe-key (key)  (defun gnus-article-describe-key (key)
5233    "Display documentation of the function invoked by KEY.  KEY is a string."    "Display documentation of the function invoked by KEY.  KEY is a string."
# Line 3898  Argument LINES specifies lines to be scr Line 5237  Argument LINES specifies lines to be scr
5237        (save-excursion        (save-excursion
5238          (set-buffer gnus-article-current-summary)          (set-buffer gnus-article-current-summary)
5239          (let (gnus-pick-mode)          (let (gnus-pick-mode)
5240            (push (elt key 0) unread-command-events)            (if (featurep 'xemacs)
5241            (setq key (if (featurep 'xemacs)                (progn
5242                          (events-to-keys (read-key-sequence "Describe key: "))                  (push (elt key 0) unread-command-events)
5243                        (read-key-sequence "Describe key: "))))                  (setq key (events-to-keys
5244                               (read-key-sequence "Describe key: "))))
5245                (setq unread-command-events
5246                      (mapcar
5247                       (lambda (x) (if (>= x 128) (list 'meta (- x 128)) x))
5248                       (string-to-list key)))
5249                (setq key (read-key-sequence "Describe key: "))))
5250          (describe-key key))          (describe-key key))
5251      (describe-key key)))      (describe-key key)))
5252    
# Line 3913  Argument LINES specifies lines to be scr Line 5258  Argument LINES specifies lines to be scr
5258        (save-excursion        (save-excursion
5259          (set-buffer gnus-article-current-summary)          (set-buffer gnus-article-current-summary)
5260          (let (gnus-pick-mode)          (let (gnus-pick-mode)
5261            (push (elt key 0) unread-command-events)            (if (featurep 'xemacs)
5262            (setq key (if (featurep 'xemacs)                (progn
5263                          (events-to-keys (read-key-sequence "Describe key: "))                  (push (elt key 0) unread-command-events)
5264                        (read-key-sequence "Describe key: "))))                  (setq key (events-to-keys
5265                               (read-key-sequence "Describe key: "))))
5266                (setq unread-command-events
5267                      (mapcar
5268                       (lambda (x) (if (>= x 128) (list 'meta (- x 128)) x))
5269                       (string-to-list key)))
5270                (setq key (read-key-sequence "Describe key: "))))
5271          (describe-key-briefly key insert))          (describe-key-briefly key insert))
5272      (describe-key-briefly key insert)))      (describe-key-briefly key insert)))
5273    
5274    (defun gnus-article-reply-with-original (&optional wide)
5275      "Start composing a reply mail to the current message.
5276    The text in the region will be yanked.  If the region isn't active,
5277    the entire article will be yanked."
5278      (interactive "P")
5279      (let ((article (cdr gnus-article-current))
5280            contents)
5281        (if (not (gnus-mark-active-p))
5282            (with-current-buffer gnus-summary-buffer
5283              (gnus-summary-reply (list (list article)) wide))
5284          (setq contents (buffer-substring (point) (mark t)))
5285          ;; Deactivate active regions.
5286          (when (and (boundp 'transient-mark-mode)
5287                     transient-mark-mode)
5288            (setq mark-active nil))
5289          (with-current-buffer gnus-summary-buffer
5290            (gnus-summary-reply
5291             (list (list article contents)) wide)))))
5292    
5293    (defun gnus-article-followup-with-original ()
5294      "Compose a followup to the current article.
5295    The text in the region will be yanked.  If the region isn't active,
5296    the entire article will be yanked."
5297      (interactive)
5298      (let ((article (cdr gnus-article-current))
5299            contents)
5300          (if (not (gnus-mark-active-p))
5301              (with-current-buffer gnus-summary-buffer
5302                (gnus-summary-followup (list (list article))))
5303            (setq contents (buffer-substring (point) (mark t)))
5304            ;; Deactivate active regions.
5305            (when (and (boundp 'transient-mark-mode)
5306                       transient-mark-mode)
5307              (setq mark-active nil))
5308            (with-current-buffer gnus-summary-buffer
5309              (gnus-summary-followup
5310               (list (list article contents)))))))
5311    
5312  (defun gnus-article-hide (&optional arg force)  (defun gnus-article-hide (&optional arg force)
5313    "Hide all the gruft in the current article.    "Hide all the gruft in the current article.
5314  This means that PGP stuff, signatures, cited text and (some)  This means that signatures, cited text and (some) headers will be
5315  headers will be hidden.  hidden.
5316  If given a prefix, show the hidden text instead."  If given a prefix, show the hidden text instead."
5317    (interactive (append (gnus-article-hidden-arg) (list 'force)))    (interactive (append (gnus-article-hidden-arg) (list 'force)))
5318    (gnus-article-hide-headers arg)    (gnus-article-hide-headers arg)
5319    (gnus-article-hide-list-identifiers arg)    (gnus-article-hide-list-identifiers arg)
   (gnus-article-hide-pgp arg)  
5320    (gnus-article-hide-citation-maybe arg force)    (gnus-article-hide-citation-maybe arg force)
5321    (gnus-article-hide-signature arg))    (gnus-article-hide-signature arg))
5322    
# Line 3944  If given a prefix, show the hidden text Line 5332  If given a prefix, show the hidden text
5332      (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name))      (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name))
5333      (gnus-request-group gnus-newsgroup-name t)))      (gnus-request-group gnus-newsgroup-name t)))
5334    
5335    (eval-when-compile
5336      (autoload 'nneething-get-file-name "nneething"))
5337    
5338  (defun gnus-request-article-this-buffer (article group)  (defun gnus-request-article-this-buffer (article group)
5339    "Get an article and insert it into this buffer."    "Get an article and insert it into this buffer."
5340    (let (do-update-line sparse-header)    (let (do-update-line sparse-header)
# Line 3993  If given a prefix, show the hidden text Line 5384  If given a prefix, show the hidden text
5384                                 gnus-newsgroup-name)))                                 gnus-newsgroup-name)))
5385                    (when (and (eq (car method) 'nneething)                    (when (and (eq (car method) 'nneething)
5386                               (vectorp header))                               (vectorp header))
5387                      (let ((dir (expand-file-name                      (let ((dir (nneething-get-file-name
5388                                  (mail-header-subject header)                                  (mail-header-id header))))
5389                                  (file-name-as-directory                        (when (and (stringp dir)
5390                                   (or (cadr (assq 'nneething-address method))                                   (file-directory-p dir))
                                      (nth 1 method))))))  
                       (when (file-directory-p dir)  
5391                          (setq article 'nneething)                          (setq article 'nneething)
5392                          (gnus-group-enter-directory dir))))))))                          (gnus-group-enter-directory dir))))))))
5393    
# Line 4037  If given a prefix, show the hidden text Line 5426  If given a prefix, show the hidden text
5426                   (numberp article)                   (numberp article)
5427                   (gnus-cache-request-article article group))                   (gnus-cache-request-article article group))
5428              'article)              'article)
5429               ;; Check the agent cache.
5430               ((gnus-agent-request-article article group)
5431                'article)
5432             ;; Get the article and put into the article buffer.             ;; Get the article and put into the article buffer.
5433             ((or (stringp article)             ((or (stringp article)
5434                  (numberp article))                  (numberp article))
5435              (let ((gnus-override-method gnus-override-method)              (let ((gnus-override-method gnus-override-method)
5436                    (methods (and (stringp article)                    (methods (and (stringp article)
5437                                  gnus-refer-article-method))                                  gnus-refer-article-method))
5438                      (backend (car (gnus-find-method-for-group
5439                                     gnus-newsgroup-name)))
5440                    result                    result
5441                    (inhibit-read-only t))                    (inhibit-read-only t))
5442                (if (or (not (listp methods))                (if (or (not (listp methods))
# Line 4061  If given a prefix, show the hidden text Line 5455  If given a prefix, show the hidden text
5455                  (gnus-kill-all-overlays)                  (gnus-kill-all-overlays)
5456                  (let ((gnus-newsgroup-name group))                  (let ((gnus-newsgroup-name group))
5457                    (gnus-check-group-server))                    (gnus-check-group-server))
5458                  (when (gnus-request-article article group (current-buffer))                  (cond
5459                     ((gnus-request-article article group (current-buffer))
5460                    (when (numberp article)                    (when (numberp article)
5461                      (gnus-async-prefetch-next group article                      (gnus-async-prefetch-next group article
5462                                                gnus-summary-buffer)                                                gnus-summary-buffer)
# Line 4069  If given a prefix, show the hidden text Line 5464  If given a prefix, show the hidden text
5464                        (gnus-backlog-enter-article                        (gnus-backlog-enter-article
5465                         group article (current-buffer))))                         group article (current-buffer))))
5466                    (setq result 'article))                    (setq result 'article))
5467                  (if (not result)                   (methods
5468                      (if methods                    (setq gnus-override-method (pop methods)))
5469                          (setq gnus-override-method (pop methods))                   ((not (string-match "^400 "
5470                        (setq result 'done))))                                       (nnheader-get-report backend)))
5471                      ;; If we get 400 server disconnect, reconnect and
5472                      ;; retry; otherwise, assume the article has expired.
5473                      (setq result 'done))))
5474                (and (eq result 'article) 'article)))                (and (eq result 'article) 'article)))
5475             ;; It was a pseudo.             ;; It was a pseudo.
5476             (t article)))             (t article)))
# Line 4092  If given a prefix, show the hidden text Line 5490  If given a prefix, show the hidden text
5490              (buffer-disable-undo)              (buffer-disable-undo)
5491              (setq major-mode 'gnus-original-article-mode)              (setq major-mode 'gnus-original-article-mode)
5492              (setq buffer-read-only t))              (setq buffer-read-only t))
5493            (let (buffer-read-only)            (let ((inhibit-read-only t))
5494              (erase-buffer)              (erase-buffer)
5495              (insert-buffer-substring gnus-article-buffer))              (insert-buffer-substring gnus-article-buffer))
5496            (setq gnus-original-article (cons group article)))            (setq gnus-original-article (cons group article)))
# Line 4110  If given a prefix, show the hidden text Line 5508  If given a prefix, show the hidden text
5508            (set-buffer gnus-summary-buffer)            (set-buffer gnus-summary-buffer)
5509            (gnus-summary-update-article do-update-line sparse-header)            (gnus-summary-update-article do-update-line sparse-header)
5510            (gnus-summary-goto-subject do-update-line nil t)            (gnus-summary-goto-subject do-update-line nil t)
5511            (set-window-point (get-buffer-window (current-buffer) t)            (set-window-point (gnus-get-buffer-window (current-buffer) t)
5512                              (point))                              (point))
5513            (set-buffer buf))))))            (set-buffer buf))))))
5514    
# Line 4126  If given a prefix, show the hidden text Line 5524  If given a prefix, show the hidden text
5524  (defvar gnus-article-edit-done-function nil)  (defvar gnus-article-edit-done-function nil)
5525    
5526  (defvar gnus-article-edit-mode-map nil)  (defvar gnus-article-edit-mode-map nil)
5527    (defvar gnus-article-edit-mode nil)
5528    
5529  ;; Should we be using derived.el for this?  ;; Should we be using derived.el for this?
5530  (unless gnus-article-edit-mode-map  (unless gnus-article-edit-mode-map
5531    (setq gnus-article-edit-mode-map (make-sparse-keymap))    (setq gnus-article-edit-mode-map (make-keymap))
5532    (set-keymap-parent gnus-article-edit-mode-map text-mode-map)    (set-keymap-parent gnus-article-edit-mode-map text-mode-map)
5533    
5534    (gnus-define-keys gnus-article-edit-mode-map    (gnus-define-keys gnus-article-edit-mode-map
5535        "\C-c?"    describe-mode
5536      "\C-c\C-c" gnus-article-edit-done      "\C-c\C-c" gnus-article-edit-done
5537      "\C-c\C-k" gnus-article-edit-exit)      "\C-c\C-k" gnus-article-edit-exit
5538        "\C-c\C-f\C-t" message-goto-to
5539        "\C-c\C-f\C-o" message-goto-from
5540        "\C-c\C-f\C-b" message-goto-bcc
5541        ;;"\C-c\C-f\C-w" message-goto-fcc
5542        "\C-c\C-f\C-c" message-goto-cc
5543        "\C-c\C-f\C-s" message-goto-subject
5544        "\C-c\C-f\C-r" message-goto-reply-to
5545        "\C-c\C-f\C-n" message-goto-newsgroups
5546        "\C-c\C-f\C-d" message-goto-distribution
5547        "\C-c\C-f\C-f" message-goto-followup-to
5548        "\C-c\C-f\C-m" message-goto-mail-followup-to
5549        "\C-c\C-f\C-k" message-goto-keywords
5550        "\C-c\C-f\C-u" message-goto-summary
5551        "\C-c\C-f\C-i" message-insert-or-toggle-importance
5552        "\C-c\C-f\C-a" message-generate-unsubscribed-mail-followup-to
5553        "\C-c\C-b" message-goto-body
5554        "\C-c\C-i" message-goto-signature
5555    
5556        "\C-c\C-t" message-insert-to
5557        "\C-c\C-n" message-insert-newsgroups
5558        "\C-c\C-o" message-sort-headers
5559        "\C-c\C-e" message-elide-region
5560        "\C-c\C-v" message-delete-not-region
5561        "\C-c\C-z" message-kill-to-signature
5562        "\M-\r" message-newline-and-reformat
5563        "\C-c\C-a" mml-attach-file
5564        "\C-a" message-beginning-of-line
5565        "\t" message-tab
5566        "\M-;" comment-region)
5567    
5568    (gnus-define-keys (gnus-article-edit-wash-map    (gnus-define-keys (gnus-article-edit-wash-map
5569                       "\C-c\C-w" gnus-article-edit-mode-map)                       "\C-c\C-w" gnus-article-edit-mode-map)
5570      "f" gnus-article-edit-full-stops))      "f" gnus-article-edit-full-stops))
5571    
5572    (easy-menu-define
5573      gnus-article-edit-mode-field-menu gnus-article-edit-mode-map ""
5574      '("Field"
5575        ["Fetch To" message-insert-to t]
5576        ["Fetch Newsgroups" message-insert-newsgroups t]
5577        "----"
5578        ["To" message-goto-to t]
5579        ["From" message-goto-from t]
5580        ["Subject" message-goto-subject t]
5581        ["Cc" message-goto-cc t]
5582        ["Reply-To" message-goto-reply-to t]
5583        ["Summary" message-goto-summary t]
5584        ["Keywords" message-goto-keywords t]
5585        ["Newsgroups" message-goto-newsgroups t]
5586        ["Followup-To" message-goto-followup-to t]
5587        ["Mail-Followup-To" message-goto-mail-followup-to t]
5588        ["Distribution" message-goto-distribution t]
5589        ["Body" message-goto-body t]
5590        ["Signature" message-goto-signature t]))
5591    
5592  (define-derived-mode gnus-article-edit-mode message-mode "Article Edit"  (define-derived-mode gnus-article-edit-mode message-mode "Article Edit"
5593    "Major mode for editing articles.    "Major mode for editing articles.
5594  This is an extended text-mode.  This is an extended text-mode.
# Line 4149  This is an extended text-mode. Line 5598  This is an extended text-mode.
5598    (make-local-variable 'gnus-prev-winconf)    (make-local-variable 'gnus-prev-winconf)
5599    (set (make-local-variable 'font-lock-defaults)    (set (make-local-variable 'font-lock-defaults)
5600         '(message-font-lock-keywords t))         '(message-font-lock-keywords t))
5601      (set (make-local-variable 'mail-header-separator) "")
5602      (set (make-local-variable 'gnus-article-edit-mode) t)
5603      (easy-menu-add message-mode-field-menu message-mode-map)
5604      (mml-mode)
5605    (setq buffer-read-only nil)    (setq buffer-read-only nil)
5606    (buffer-enable-undo)    (buffer-enable-undo)
5607    (widen))    (widen))
# Line 4177  groups." Line 5630  groups."
5630      (set-buffer gnus-article-buffer)      (set-buffer gnus-article-buffer)
5631      (gnus-article-edit-mode)      (gnus-article-edit-mode)
5632      (funcall start-func)      (funcall start-func)
5633        (set-buffer-modified-p nil)
5634      (gnus-configure-windows 'edit-article)      (gnus-configure-windows 'edit-article)
5635      (setq gnus-article-edit-done-function exit-func)      (setq gnus-article-edit-done-function exit-func)
5636      (setq gnus-prev-winconf winconf)      (setq gnus-prev-winconf winconf)
# Line 4185  groups." Line 5639  groups."
5639  (defun gnus-article-edit-done (&optional arg)  (defun gnus-article-edit-done (&optional arg)
5640    "Update the article edits and exit."    "Update the article edits and exit."
5641    (interactive "P")    (interactive "P")
   (widen)  
   (save-excursion  
     (save-restriction  
       (when (article-goto-body)  
         (let ((lines (count-lines (point) (point-max)))  
               (length (- (point-max) (point)))  
               (case-fold-search t)  
               (body (copy-marker (point))))  
           (goto-char (point-min))  
           (when (re-search-forward "^content-length:[ \t]\\([0-9]+\\)" body t)  
             (delete-region (match-beginning 1) (match-end 1))  
             (insert (number-to-string length)))  
           (goto-char (point-min))  
           (when (re-search-forward  
                  "^x-content-length:[ \t]\\([0-9]+\\)" body t)  
             (delete-region (match-beginning 1) (match-end 1))  
             (insert (number-to-string length)))  
           (goto-char (point-min))  
           (when (re-search-forward "^lines:[ \t]\\([0-9]+\\)" body t)  
             (delete-region (match-beginning 1) (match-end 1))  
             (insert (number-to-string lines)))))))  
5642    (let ((func gnus-article-edit-done-function)    (let ((func gnus-article-edit-done-function)
5643          (buf (current-buffer))          (buf (current-buffer))
5644          (start (window-start)))          (start (window-start))
5645      (gnus-article-edit-exit)          (p (point))
5646            (winconf gnus-prev-winconf))
5647        (widen) ;; Widen it in case that users narrowed the buffer.
5648        (funcall func arg)
5649        (set-buffer buf)
5650        ;; The cache and backlog have to be flushed somewhat.
5651        (when gnus-keep-backlog
5652          (gnus-backlog-remove-article
5653           (car gnus-article-current) (cdr gnus-article-current)))
5654        ;; Flush original article as well.
5655      (save-excursion      (save-excursion
5656        (set-buffer buf)        (when (get-buffer gnus-original-article-buffer)
5657        (let ((inhibit-read-only t))          (set-buffer gnus-original-article-buffer)
5658          (funcall func arg))          (setq gnus-original-article nil)))
5659        ;; The cache and backlog have to be flushed somewhat.      (when gnus-use-cache
5660        (when gnus-keep-backlog        (gnus-cache-update-article
5661          (gnus-backlog-remove-article         (car gnus-article-current) (cdr gnus-article-current)))
5662           (car gnus-article-current) (cdr gnus-article-current)))      ;; We remove all text props from the article buffer.
5663        ;; Flush original article as well.      (kill-all-local-variables)
5664        (save-excursion      (gnus-set-text-properties (point-min) (point-max) nil)
5665          (when (get-buffer gnus-original-article-buffer)      (gnus-article-mode)
5666            (set-buffer gnus-original-article-buffer)      (set-window-configuration winconf)
           (setq gnus-original-article nil)))  
       (when gnus-use-cache  
         (gnus-cache-update-article  
          (car gnus-article-current) (cdr gnus-article-current))))  
5667      (set-buffer buf)      (set-buffer buf)
5668      (set-window-start (get-buffer-window buf) start)      (set-window-start (get-buffer-window buf) start)
5669      (set-window-point (get-buffer-window buf) (point))))      (set-window-point (get-buffer-window buf) (point)))
5670      (gnus-summary-show-article))
5671    
5672  (defun gnus-article-edit-exit ()  (defun gnus-article-edit-exit ()
5673    "Exit the article editing without updating."    "Exit the article editing without updating."
5674    (interactive)    (interactive)
5675    ;; We remove all text props from the article buffer.    (when (or (not (buffer-modified-p))
5676    (let ((buf (buffer-substring-no-properties (point-min) (point-max)))              (yes-or-no-p "Article modified; kill anyway? "))
5677          (curbuf (current-buffer))      (let ((curbuf (current-buffer))
5678          (p (point))            (p (point))
5679          (window-start (window-start)))            (window-start (window-start)))
5680      (erase-buffer)        (erase-buffer)
5681      (insert buf)        (if (gnus-buffer-live-p gnus-original-article-buffer)
5682      (let ((winconf gnus-prev-winconf))            (insert-buffer gnus-original-article-buffer))
5683        (gnus-article-mode)        (let ((winconf gnus-prev-winconf))
5684        (set-window-configuration winconf)          (kill-all-local-variables)
5685        ;; Tippy-toe some to make sure that point remains where it was.          (gnus-article-mode)
5686        (save-current-buffer          (set-window-configuration winconf)
5687          (set-buffer curbuf)          ;; Tippy-toe some to make sure that point remains where it was.
5688          (set-window-start (get-buffer-window (current-buffer)) window-start)          (save-current-buffer
5689          (goto-char p)))))            (set-buffer curbuf)
5690              (set-window-start (get-buffer-window (current-buffer)) window-start)
5691              (goto-char p))))
5692        (gnus-summary-show-article)))
5693    
5694  (defun gnus-article-edit-full-stops ()  (defun gnus-article-edit-full-stops ()
5695    "Interactively repair spacing at end of sentences."    "Interactively repair spacing at end of sentences."
# Line 4268  groups." Line 5710  groups."
5710    
5711  (defcustom gnus-button-url-regexp  (defcustom gnus-button-url-regexp
5712    (if (string-match "[[:digit:]]" "1") ;; support POSIX?    (if (string-match "[[:digit:]]" "1") ;; support POSIX?
5713        "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?[-a-zA-Z0-9_=!?#$@~`%&*+|\\/:;.,[:word:]]+[-a-zA-Z0-9_=#$@~`%&*+|\\/[:word:]]\\)"        "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)\\(//[-a-z0-9_.]+:[0-9]*\\)?[-a-z0-9_=!?#$@~%&*+\\/:;.,[:word:]]+[-a-z0-9_=#$@~%&*+\\/[:word:]]\\)"
5714      "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?\\([-a-zA-Z0-9_=!?#$@~`%&*+|\\/:;.,]\\|\\w\\)+\\([-a-zA-Z0-9_=#$@~`%&*+|\\/]\\|\\w\\)\\)")      "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)\\(//[-a-z0-9_.]+:[0-9]*\\)?\\([-a-z0-9_=!?#$@~%&*+\\/:;.,]\\|\\w\\)+\\([-a-z0-9_=#$@~%&*+\\/]\\|\\w\\)\\)")
5715    "Regular expression that matches URLs."    "Regular expression that matches URLs."
5716    :group 'gnus-article-buttons    :group 'gnus-article-buttons
5717    :type 'regexp)    :type 'regexp)
5718    
5719    (defcustom gnus-button-valid-fqdn-regexp
5720      message-valid-fqdn-regexp
5721      "Regular expression that matches a valid FQDN."
5722      :group 'gnus-article-buttons
5723      :type 'regexp)
5724    
5725    (defcustom gnus-button-man-handler 'manual-entry
5726      "Function to use for displaying man pages.
5727    The function must take at least one argument with a string naming the
5728    man page."
5729      :type '(choice (function-item :tag "Man" manual-entry)
5730                     (function-item :tag "Woman" woman)
5731                     (function :tag "Other"))
5732      :group 'gnus-article-buttons)
5733    
5734    (defcustom gnus-ctan-url "http://tug.ctan.org/tex-archive/"
5735      "Top directory of a CTAN \(Comprehensive TeX Archive Network\) archive.
5736    If the default site is too slow, try to find a CTAN mirror, see
5737    <URL:http://tug.ctan.org/tex-archive/CTAN.sites?action=/index.html>.  See also
5738    the variable `gnus-button-handle-ctan'."
5739      :group 'gnus-article-buttons
5740      :link '(custom-manual "(gnus)Group Parameters")
5741      :type '(choice (const "http://www.tex.ac.uk/tex-archive/")
5742                     (const "http://tug.ctan.org/tex-archive/")
5743                     (const "http://www.dante.de/CTAN/")
5744                     (string :tag "Other")))
5745    
5746    (defcustom gnus-button-ctan-handler 'browse-url
5747      "Function to use for displaying CTAN links.
5748    The function must take one argument, the string naming the URL."
5749      :type '(choice (function-item :tag "Browse Url" browse-url)
5750                     (function :tag "Other"))
5751      :group 'gnus-article-buttons)
5752    
5753    (defcustom gnus-button-handle-ctan-bogus-regexp "^/?tex-archive/\\|^/"
5754      "Bogus strings removed from CTAN URLs."
5755      :group 'gnus-article-buttons
5756      :type '(choice (const "^/?tex-archive/\\|/")
5757                     (regexp :tag "Other")))
5758    
5759    (defcustom gnus-button-ctan-directory-regexp
5760      (concat
5761       "\\("; Cannot use `\(?: ... \)' (compatibility with Emacs 20).
5762       "biblio\\|digests\\|dviware\\|fonts\\|graphics\\|help\\|"
5763       "indexing\\|info\\|language\\|macros\\|support\\|systems\\|"
5764       "tds\\|tools\\|usergrps\\|web\\|nonfree\\|obsolete"
5765       "\\)")
5766      "Regular expression for ctan directories.
5767    It should match all directories in the top level of `gnus-ctan-url'."
5768      :group 'gnus-article-buttons
5769      :type 'regexp)
5770    
5771    (defcustom gnus-button-mid-or-mail-regexp
5772      (concat "\\b\\(<?[a-z0-9$%(*-=?[_][^<>\")!;:,{}\n\t ]*@"
5773              ;; Felix Wiemann in <87oeuomcz9.fsf@news2.ososo.de>
5774              gnus-button-valid-fqdn-regexp
5775              ">?\\)\\b")
5776      "Regular expression that matches a message ID or a mail address."
5777      :group 'gnus-article-buttons
5778      :type 'regexp)
5779    
5780    (defcustom gnus-button-prefer-mid-or-mail 'gnus-button-mid-or-mail-heuristic
5781      "What to do when the button on a string as \"foo123@bar.invalid\" is pushed.
5782    Strings like this can be either a message ID or a mail address.  If it is one
5783    of the symbols `mid' or `mail', Gnus will always assume that the string is a
5784    message ID or a mail address, respectively.  If this variable is set to the
5785    symbol `ask', always query the user what do do.  If it is a function, this
5786    function will be called with the string as it's only argument.  The function
5787    must return `mid', `mail', `invalid' or `ask'."
5788      :group 'gnus-article-buttons
5789      :type '(choice (function-item :tag "Heuristic function"
5790                                    gnus-button-mid-or-mail-heuristic)
5791                     (const ask)
5792                     (const mid)
5793                     (const mail)))
5794    
5795    (defcustom gnus-button-mid-or-mail-heuristic-alist
5796      '((-10.0 . ".+\\$.+@")
5797        (-10.0 . "#")
5798        (-10.0 . "\\*")
5799        (-5.0  . "\\+[^+]*\\+.*@") ;; # two plus signs
5800        (-5.0  . "@[Nn][Ee][Ww][Ss]") ;; /\@news/i
5801        (-5.0  . "@.*[Dd][Ii][Aa][Ll][Uu][Pp]") ;; /\@.*dialup/i;
5802        (-1.0  . "^[^a-z]+@")
5803        ;;
5804        (-5.0  . "\\.[0-9][0-9]+.*@") ;; "\.[0-9]{2,}.*\@"
5805        (-5.0  . "[a-z].*[A-Z].*[a-z].*[A-Z].*@") ;; "([a-z].*[A-Z].*){2,}\@"
5806        (-3.0  . "[A-Z][A-Z][a-z][a-z].*@")
5807        (-5.0  . "\\...?.?@") ;; (-5.0 . "\..{1,3}\@")
5808        ;;
5809        (-2.0  . "^[0-9]")
5810        (-1.0  . "^[0-9][0-9]")
5811        ;;
5812        ;; -3.0 /^[0-9][0-9a-fA-F]{2,2}/;
5813        (-3.0  . "^[0-9][0-9a-fA-F][0-9a-fA-F][^0-9a-fA-F]")
5814        ;; -5.0 /^[0-9][0-9a-fA-F]{3,3}/;
5815        (-5.0  . "^[0-9][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][^0-9a-fA-F]")
5816        ;;
5817        (-3.0  .  "[0-9][0-9][0-9][0-9][0-9][^0-9].*@") ;; "[0-9]{5,}.*\@"
5818        (-3.0  .  "[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][^0-9].*@")
5819        ;;       "[0-9]{8,}.*\@"
5820        (-3.0
5821         . "[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9].*@")
5822        ;; "[0-9]{12,}.*\@"
5823        ;; compensation for TDMA dated mail addresses:
5824        (25.0  . "-dated-[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]+.*@")
5825        ;;
5826        (-20.0 . "\\.fsf@") ;; Gnus
5827        (-20.0 . "^slrn")
5828        (-20.0 . "^Pine")
5829        (-20.0 . "_-_") ;; Subject change in thread
5830        ;;
5831        (-20.0 . "\\.ln@") ;; leafnode
5832        (-30.0 . "@ID-[0-9]+\\.[a-zA-Z]+\\.dfncis\\.de")
5833        (-30.0 . "@4[Aa][Xx]\\.com") ;; Forte Agent
5834        ;;
5835        ;; (5.0 . "") ;; $local_part_len <= 7
5836        (10.0  . "^[^0-9]+@")
5837        (3.0   . "^[^0-9]+[0-9][0-9]?[0-9]?@")
5838        ;;      ^[^0-9]+[0-9]{1,3}\@ digits only at end of local part
5839        (3.0   . "\@stud")
5840        ;;
5841        (2.0   . "[a-z][a-z][._-][A-Z][a-z].*@")
5842        ;;
5843        (0.5   . "^[A-Z][a-z]")
5844        (0.5   . "^[A-Z][a-z][a-z]")
5845        (1.5   . "^[A-Z][a-z][A-Z][a-z][^a-z]") ;; ^[A-Z][a-z]{3,3}
5846        (2.0   . "^[A-Z][a-z][A-Z][a-z][a-z][^a-z]")) ;; ^[A-Z][a-z]{4,4}
5847      "An alist of \(RATE . REGEXP\) pairs for `gnus-button-mid-or-mail-heuristic'.
5848    
5849    A negative RATE indicates a message IDs, whereas a positive indicates a mail
5850    address.  The REGEXP is processed with `case-fold-search' set to nil."
5851      :group 'gnus-article-buttons
5852      :type '(repeat (cons (number :tag "Rate")
5853                           (regexp :tag "Regexp"))))
5854    
5855    (defun gnus-button-mid-or-mail-heuristic (mid-or-mail)
5856      "Guess whether MID-OR-MAIL is a message ID or a mail address.
5857    Returns `mid' if MID-OR-MAIL is a message IDs, `mail' if it's a mail
5858    address, `ask' if unsure and `invalid' if the string is invalid."
5859      (let ((case-fold-search nil)
5860            (list gnus-button-mid-or-mail-heuristic-alist)
5861            (result 0) rate regexp lpartlen elem)
5862        (setq lpartlen
5863              (length (gnus-replace-in-string mid-or-mail "^\\(.*\\)@.*$" "\\1")))
5864        (gnus-message 8 "`%s', length of local part=`%s'." mid-or-mail lpartlen)
5865        ;; Certain special cases...
5866        (when (string-match
5867               (concat
5868                "^0[0-9]+-[0-9][0-9][0-9][0-9]@t-online\\.de$\\|"
5869                "^[0-9]+\\.[0-9]+@compuserve\\|"
5870                "@public\\.gmane\\.org")
5871               mid-or-mail)
5872          (gnus-message 8 "`%s' is a known mail address." mid-or-mail)
5873          (setq result 'mail))
5874        (when (string-match "@.*@\\| " mid-or-mail)
5875          (gnus-message 8 "`%s' is invalid." mid-or-mail)
5876          (setq result 'invalid))
5877        ;; Nothing more to do, if result is not a number here...
5878        (when (numberp result)
5879          (while list
5880            (setq elem (car list)
5881                  rate (car elem)
5882                  regexp (cdr elem)
5883                  list (cdr list))
5884            (when (string-match regexp mid-or-mail)
5885              (setq result (+ result rate))
5886              (gnus-message
5887               9 "`%s' matched `%s', rate `%s', result `%s'."
5888               mid-or-mail regexp rate result)))
5889          (when (<= lpartlen 7)
5890            (setq result (+ result 5.0))
5891            (gnus-message 9 "`%s' matched (<= lpartlen 7), result `%s'."
5892                          mid-or-mail result))
5893          (when (>= lpartlen 12)
5894            (gnus-message 9 "`%s' matched (>= lpartlen 12)" mid-or-mail)
5895            (cond
5896             ((string-match "[0-9][^0-9]+[0-9].*@" mid-or-mail)
5897              ;; Long local part should contain realname if e-mail address,
5898              ;; too many digits: message-id.
5899              ;; $score -= 5.0 + 0.1 * $local_part_len;
5900              (setq rate (* -1.0 (+ 5.0 (* 0.1 lpartlen))))
5901              (setq result (+ result rate))
5902              (gnus-message
5903               9 "Many digits in `%s', rate `%s', result `%s'."
5904               mid-or-mail rate result))
5905             ((string-match "[^aeiouy][^aeiouy][^aeiouy][^aeiouy]+.*\@"
5906                            mid-or-mail)
5907              ;; Too few vowels [^aeiouy]{4,}.*\@
5908              (setq result (+ result -5.0))
5909              (gnus-message
5910               9 "Few vowels in `%s', rate `%s', result `%s'."
5911               mid-or-mail -5.0 result))
5912             (t
5913              (setq result (+ result 5.0))
5914              (gnus-message
5915               9 "`%s', rate `%s', result `%s'." mid-or-mail 5.0 result)))))
5916        (gnus-message 8 "`%s': Final rate is `%s'." mid-or-mail result)
5917        ;; Maybe we should make this a customizable alist: (condition . 'result)
5918        (cond
5919         ((symbolp result) result)
5920         ;; Now convert number into proper results:
5921         ((< result -10.0) 'mid)
5922         ((> result  10.0) 'mail)
5923         (t 'ask))))
5924    
5925    (defun gnus-button-handle-mid-or-mail (mid-or-mail)
5926      (let* ((pref gnus-button-prefer-mid-or-mail) guessed
5927             (url-mid (concat "news" ":" mid-or-mail))
5928             (url-mailto (concat "mailto" ":" mid-or-mail)))
5929        (gnus-message 9 "mid-or-mail=%s" mid-or-mail)
5930        (when (fboundp pref)
5931          (setq guessed
5932                ;; get rid of surrounding angles...
5933                (funcall pref
5934                         (gnus-replace-in-string mid-or-mail "^<\\|>$" "")))
5935          (if (or (eq 'mid guessed) (eq 'mail guessed))
5936              (setq pref guessed)
5937            (setq pref 'ask)))
5938        (if (eq pref 'ask)
5939            (save-window-excursion
5940              (if (y-or-n-p (concat "Is <" mid-or-mail "> a mail address? "))
5941                  (setq pref 'mail)
5942                (setq pref 'mid))))
5943        (cond ((eq pref 'mid)
5944               (gnus-message 8 "calling `gnus-button-handle-news' %s" url-mid)
5945               (gnus-button-handle-news url-mid))
5946              ((eq pref 'mail)
5947               (gnus-message 8 "calling `gnus-url-mailto'  %s" url-mailto)
5948               (gnus-url-mailto url-mailto))
5949              (t (gnus-message 3 "Invalid string.")))))
5950    
5951    (defun gnus-button-handle-custom (url)
5952      "Follow a Custom URL."
5953      (customize-apropos (gnus-url-unhex-string url)))
5954    
5955    (defvar gnus-button-handle-describe-prefix "^\\(C-h\\|<?[Ff]1>?\\)")
5956    
5957    ;; FIXME: Maybe we should merge some of the functions that do quite similar
5958    ;; stuff?
5959    
5960    (defun gnus-button-handle-describe-function (url)
5961      "Call `describe-function' when pushing the corresponding URL button."
5962      (describe-function
5963       (intern
5964        (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))))
5965    
5966    (defun gnus-button-handle-describe-variable (url)
5967      "Call `describe-variable' when pushing the corresponding URL button."
5968      (describe-variable
5969       (intern
5970        (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))))
5971    
5972    (defun gnus-button-handle-symbol (url)
5973    "Display help on variable or function.
5974    Calls `describe-variable' or `describe-function'."
5975      (let ((sym (intern url)))
5976        (cond
5977         ((fboundp sym) (describe-function sym))
5978         ((boundp sym) (describe-variable sym))
5979         (t (gnus-message 3 "`%s' is not a known function of variable." url)))))
5980    
5981    (defun gnus-button-handle-describe-key (url)
5982      "Call `describe-key' when pushing the corresponding URL button."
5983      (let* ((key-string
5984              (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))
5985             (keys (ignore-errors (eval `(kbd ,key-string)))))
5986        (if keys
5987            (describe-key keys)
5988          (gnus-message 3 "Invalid key sequence in button: %s" key-string))))
5989    
5990    (defun gnus-button-handle-apropos (url)
5991      "Call `apropos' when pushing the corresponding URL button."
5992      (apropos (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))
5993    
5994    (defun gnus-button-handle-apropos-command (url)
5995      "Call `apropos' when pushing the corresponding URL button."
5996      (apropos-command
5997       (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))
5998    
5999    (defun gnus-button-handle-apropos-variable (url)
6000      "Call `apropos' when pushing the corresponding URL button."
6001      (funcall
6002       (if (fboundp 'apropos-variable) 'apropos-variable 'apropos)
6003       (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))
6004    
6005    (defun gnus-button-handle-apropos-documentation (url)
6006      "Call `apropos' when pushing the corresponding URL button."
6007      (funcall
6008       (if (fboundp 'apropos-documentation) 'apropos-documentation 'apropos)
6009       (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))
6010    
6011    (defun gnus-button-handle-library (url)
6012      "Call `locate-library' when pushing the corresponding URL button."
6013      (gnus-message 9 "url=`%s'" url)
6014      (let* ((lib (locate-library url))
6015             (file (gnus-replace-in-string (or lib "") "\.elc" ".el")))
6016        (if (not lib)
6017            (gnus-message 1 "Cannot locale library `%s'." url)
6018          (find-file-read-only file))))
6019    
6020    (defun gnus-button-handle-ctan (url)
6021      "Call `browse-url' when pushing a CTAN URL button."
6022      (funcall
6023       gnus-button-ctan-handler
6024       (concat
6025        gnus-ctan-url
6026        (gnus-replace-in-string url gnus-button-handle-ctan-bogus-regexp ""))))
6027    
6028    (defcustom gnus-button-tex-level 5
6029      "*Integer that says how many TeX-related buttons Gnus will show.
6030    The higher the number, the more buttons will appear and the more false
6031    positives are possible.  Note that you can set this variable local to
6032    specific groups.  Setting it higher in TeX groups is probably a good idea.
6033    See Info node `(gnus)Group Parameters' and the variable `gnus-parameters' on
6034    how to set variables in specific groups."
6035      :group 'gnus-article-buttons
6036      :link '(custom-manual "(gnus)Group Parameters")
6037      :type 'integer)
6038    
6039    (defcustom gnus-button-man-level 5
6040      "*Integer that says how many man-related buttons Gnus will show.
6041    The higher the number, the more buttons will appear and the more false
6042    positives are possible.  Note that you can set this variable local to
6043    specific groups.  Setting it higher in Unix groups is probably a good idea.
6044    See Info node `(gnus)Group Parameters' and the variable `gnus-parameters' on
6045    how to set variables in specific groups."
6046      :group 'gnus-article-buttons
6047      :link '(custom-manual "(gnus)Group Parameters")
6048      :type 'integer)
6049    
6050    (defcustom gnus-button-emacs-level 5
6051      "*Integer that says how many emacs-related buttons Gnus will show.
6052    The higher the number, the more buttons will appear and the more false
6053    positives are possible.  Note that you can set this variable local to
6054    specific groups.  Setting it higher in Emacs or Gnus related groups is
6055    probably a good idea.  See Info node `(gnus)Group Parameters' and the variable
6056    `gnus-parameters' on how to set variables in specific groups."
6057      :group 'gnus-article-buttons
6058      :link '(custom-manual "(gnus)Group Parameters")
6059      :type 'integer)
6060    
6061    (defcustom gnus-button-message-level 5
6062      "*Integer that says how many buttons for news or mail messages will appear.
6063    The higher the number, the more buttons will appear and the more false
6064    positives are possible."
6065      ;; mail addresses, MIDs, URLs for news, ...
6066      :group 'gnus-article-buttons
6067      :type 'integer)
6068    
6069    (defcustom gnus-button-browse-level 5
6070      "*Integer that says how many buttons for browsing will appear.
6071    The higher the number, the more buttons will appear and the more false
6072    positives are possible."
6073      ;; stuff handled by `browse-url' or `gnus-button-embedded-url'
6074      :group 'gnus-article-buttons
6075      :type 'integer)
6076    
6077  (defcustom gnus-button-alist  (defcustom gnus-button-alist
6078    `(("<\\(url:[>\n\t ]*?\\)?news:[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>"    '(("<\\(url:[>\n\t ]*?\\)?\\(nntp\\|news\\):[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>"
6079       0 t gnus-button-message-id 2)       0 (>= gnus-button-message-level 0) gnus-button-handle-news 3)
6080      ("\\bnews:\\([^>\n\t ]*@[^>)!;:,\n\t ]*\\)" 0 t gnus-button-message-id 1)      ("\\b\\(nntp\\|news\\):\\([^>\n\t ]*@[^>)!;:,\n\t ]*\\)" 0 t
6081      ("\\(\\b<\\(url:[>\n\t ]*\\)?news:[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)"       gnus-button-handle-news 2)
6082       1 t      ("\\(\\b<\\(url:[>\n\t ]*\\)?\\(nntp\\|news\\):[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)"
6083       gnus-button-fetch-group 4)       1 (>= gnus-button-message-level 0) gnus-button-fetch-group 5)
6084      ("\\bnews:\\(//\\)?\\([^'\">\n\t ]+\\)" 0 t gnus-button-fetch-group 2)      ("\\b\\(nntp\\|news\\):\\(//\\)?\\([^'\">\n\t ]+\\)"
6085      ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2       0 (>= gnus-button-message-level 0) gnus-button-fetch-group 3)
6086       t gnus-button-message-id 3)      ;; RFC 2392 (Don't allow `/' in domain part --> CID)
6087      ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>" 0 t gnus-url-mailto 2)      ("\\bmid:\\(//\\)?\\([^'\">\n\t ]+@[^'\">\n\t /]+\\)"
6088      ("mailto:\\([-a-zA-Z.@_+0-9%]+\\)" 0 t gnus-url-mailto 1)       0 (>= gnus-button-message-level 0) gnus-button-message-id 2)
6089      ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1)      ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)"
6090      ;; This is how URLs _should_ be embedded in text...       2 (>= gnus-button-message-level 0) gnus-button-message-id 3)
6091      ("<URL: *\\([^<>]*\\)>" 0 t gnus-button-embedded-url 1)      ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>"
6092      ;; Info manual references.       0 (>= gnus-button-message-level 0) gnus-url-mailto 2)
6093      ("(\\(info\\|Info-goto-node\\)[ \n\t]+\"\\(([^)\"\n]+)[^\"\n]+\\)\")"      ;; RFC 2368 (The mailto URL scheme)
6094       0 t Info-goto-node 2)      ("mailto:\\([-a-z.@_+0-9%=?&]+\\)"
6095         0 (>= gnus-button-message-level 0) gnus-url-mailto 1)
6096        ("\\bmailto:\\([^ \n\t]+\\)"
6097         0 (>= gnus-button-message-level 0) gnus-url-mailto 1)
6098        ;; CTAN
6099        ((concat "\\bCTAN:[ \t\n]?[^>)!;:,'\n\t ]*\\("
6100                 gnus-button-ctan-directory-regexp
6101                 "[^][>)!;:,'\n\t ]+\\)")
6102         0 (>= gnus-button-tex-level 1) gnus-button-handle-ctan 1)
6103        ((concat "\\btex-archive/\\("
6104                 gnus-button-ctan-directory-regexp
6105                 "/[-_.a-z0-9/]+[-_./a-z0-9]+[/a-z0-9]\\)")
6106         1 (>= gnus-button-tex-level 6) gnus-button-handle-ctan 1)
6107        ((concat
6108          "\\b\\("
6109          gnus-button-ctan-directory-regexp
6110          "/[-_.a-z0-9]+/[-_./a-z0-9]+[/a-z0-9]\\)")
6111         1 (>= gnus-button-tex-level 8) gnus-button-handle-ctan 1)
6112        ;; This is info (home-grown style) <info://foo/bar+baz>
6113        ("\\binfo://\\([^'\">\n\t ]+\\)"
6114         0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url 1)
6115        ;; Info GNOME style <info:foo#bar_baz>
6116        ("\\binfo:\\([^('\n\t\r \"><][^'\n\t\r \"><]*\\)"
6117         0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url-gnome 1)
6118        ;; Info KDE style <info:(foo)bar baz>
6119        ("<\\(info:\\(([^)]+)[^>\n\r]*\\)\\)>"
6120         1 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url-kde 2)
6121        ("\\((Info-goto-node\\|(info\\)[ \t\n]*\\(\"[^\"]*\"\\))" 0
6122         (>= gnus-button-emacs-level 1) gnus-button-handle-info-url 2)
6123        ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+i[ \t\n]+d?[ \t\n]?m[ \t\n]+\\([^ ]+ ?[^ ]+\\)[ \t\n]+RET"
6124         ;; Info links like `C-h i d m CC Mode RET'
6125         0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-keystrokes 2)
6126        ;; This is custom
6127        ("\\bcustom:\\(//\\)?\\([^'\">\n\t ]+\\)"
6128         0 (>= gnus-button-emacs-level 5) gnus-button-handle-custom 2)
6129        ("M-x[ \t\n]customize-[^ ]+[ \t\n]RET[ \t\n]\\([^ ]+\\)[ \t\n]RET" 0
6130         (>= gnus-button-emacs-level 1) gnus-button-handle-custom 1)
6131        ;; Emacs help commands
6132        ("M-x[ \t\n]+apropos[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
6133         ;; regexp doesn't match arguments containing ` '.
6134         0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos 1)
6135        ("M-x[ \t\n]+apropos-command[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
6136         0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-command 1)
6137        ("M-x[ \t\n]+apropos-variable[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
6138         0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-variable 1)
6139        ("M-x[ \t\n]+apropos-documentation[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
6140         0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-documentation 1)
6141        ;; The following entries may lead to many false positives so don't enable
6142        ;; them by default (use a high button level):
6143        ("/\\([a-z][-a-z0-9]+\\.el\\)\\>"
6144         1 (>= gnus-button-emacs-level 8) gnus-button-handle-library 1)
6145        ("`\\([a-z][-a-z0-9]+\\.el\\)'"
6146         1 (>= gnus-button-emacs-level 8) gnus-button-handle-library 1)
6147        ("`\\([a-z][a-z0-9]+-[a-z]+-[-a-z]+\\|\\(gnus\\|message\\)-[-a-z]+\\)'"
6148         0 (>= gnus-button-emacs-level 8) gnus-button-handle-symbol 1)
6149        ("`\\([a-z][a-z0-9]+-[a-z]+\\)'"
6150         0 (>= gnus-button-emacs-level 9) gnus-button-handle-symbol 1)
6151        ("(setq[ \t\n]+\\([a-z][a-z0-9]+-[-a-z0-9]+\\)[ \t\n]+.+)"
6152         1 (>= gnus-button-emacs-level 7) gnus-button-handle-describe-variable 1)
6153        ("\\bM-x[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
6154         1 (>= gnus-button-emacs-level 7) gnus-button-handle-describe-function 1)
6155        ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+f[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
6156         0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-function 2)
6157        ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+v[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
6158         0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-variable 2)
6159        ("`\\(\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+k[ \t\n]+\\([^']+\\)\\)'"
6160         ;; Unlike the other regexps we really have to require quoting
6161         ;; here to determine where it ends.
6162         1 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-key 3)
6163        ;; This is how URLs _should_ be embedded in text (RFC 1738, RFC 2396)...
6164        ("<URL: *\\([^<>]*\\)>"
6165         1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1)
6166        ;; RFC 2396 (2.4.3., delims) ...
6167        ("\"URL: *\\([^\"]*\\)\""
6168         1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1)
6169        ;; RFC 2396 (2.4.3., delims) ...
6170        ("\"URL: *\\([^\"]*\\)\""
6171         1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1)
6172      ;; Raw URLs.      ;; Raw URLs.
6173      (,gnus-button-url-regexp 0 t browse-url 0))      (gnus-button-url-regexp
6174         0 (>= gnus-button-browse-level 0) browse-url 0)
6175        ;; man pages
6176        ("\\b\\([a-z][a-z]+\\)([1-9])\\W"
6177         0 (and (>= gnus-button-man-level 1) (< gnus-button-man-level 3))
6178         gnus-button-handle-man 1)
6179        ;; more man pages: resolv.conf(5), iso_8859-1(7), xterm(1x)
6180        ("\\b\\([a-z][-_.a-z0-9]+\\)([1-9])\\W"
6181         0 (and (>= gnus-button-man-level 3) (< gnus-button-man-level 5))
6182         gnus-button-handle-man 1)
6183        ;; even more: Apache::PerlRun(3pm), PDL::IO::FastRaw(3pm),
6184        ;; SoWWWAnchor(3iv), XSelectInput(3X11), X(1), X(7)
6185        ("\\b\\([a-z][-+_.:a-z0-9]+\\)([1-9][X1a-z]*)\\W\\|\\b\\(X\\)([1-9])\\W"
6186         0 (>= gnus-button-man-level 5) gnus-button-handle-man 1)
6187        ;; MID or mail: To avoid too many false positives we don't try to catch
6188        ;; all kind of allowed MIDs or mail addresses.  Domain part must contain
6189        ;; at least one dot.  TLD must contain two or three chars or be a know TLD
6190        ;; (info|name|...).  Put this entry near the _end_ of `gnus-button-alist'
6191        ;; so that non-ambiguous entries (see above) match first.
6192        (gnus-button-mid-or-mail-regexp
6193         0 (>= gnus-button-message-level 5) gnus-button-handle-mid-or-mail 1))
6194    "*Alist of regexps matching buttons in article bodies.    "*Alist of regexps matching buttons in article bodies.
6195    
6196  Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where  Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where
6197  REGEXP: is the string matching text around the button,  REGEXP: is the string (case insensitive) matching text around the button (can
6198    also be Lisp expression evaluating to a string),
6199  BUTTON: is the number of the regexp grouping actually matching the button,  BUTTON: is the number of the regexp grouping actually matching the button,
6200  FORM: is a Lisp expression which must eval to true for the button to  FORM: is a Lisp expression which must eval to true for the button to
6201  be added,  be added,
# Line 4307  PAR: is a number of a regexp grouping wh Line 6205  PAR: is a number of a regexp grouping wh
6205  CALLBACK can also be a variable, in that case the value of that  CALLBACK can also be a variable, in that case the value of that
6206  variable it the real callback function."  variable it the real callback function."
6207    :group 'gnus-article-buttons    :group 'gnus-article-buttons
6208    :type '(repeat (list regexp    :type '(repeat (list (choice regexp variable sexp)
6209                         (integer :tag "Button")                         (integer :tag "Button")
6210                         (sexp :tag "Form")                         (sexp :tag "Form")
6211                         (function :tag "Callback")                         (function :tag "Callback")
# Line 4316  variable it the real callback function." Line 6214  variable it the real callback function."
6214                                 (integer :tag "Regexp group")))))                                 (integer :tag "Regexp group")))))
6215    
6216  (defcustom gnus-header-button-alist  (defcustom gnus-header-button-alist
6217    `(("^\\(References\\|Message-I[Dd]\\):" "<[^>]+>"    '(("^\\(References\\|Message-I[Dd]\\|^In-Reply-To\\):" "<[^<>]+>"
6218       0 t gnus-button-message-id 0)       0 (>= gnus-button-message-level 0) gnus-button-message-id 0)
6219      ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 t gnus-button-reply 1)      ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$"
6220         1 (>= gnus-button-message-level 0) gnus-button-reply 1)
6221      ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+"      ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+"
6222       0 t gnus-button-mailto 0)       0 (>= gnus-button-message-level 0) gnus-button-mailto 0)
6223      ("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t browse-url 0)      ("^X-[Uu][Rr][Ll]:" gnus-button-url-regexp
6224      ("^Subject:" ,gnus-button-url-regexp 0 t browse-url 0)       0 (>= gnus-button-browse-level 0) browse-url 0)
6225      ("^[^:]+:" ,gnus-button-url-regexp 0 t browse-url 0)      ("^Subject:" gnus-button-url-regexp
6226      ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t       0 (>= gnus-button-browse-level 0) browse-url 0)
6227       gnus-button-message-id 3))      ("^[^:]+:" gnus-button-url-regexp
6228         0 (>= gnus-button-browse-level 0) browse-url 0)
6229        ("^[^:]+:" "\\bmailto:\\([-a-z.@_+0-9%=?&]+\\)"
6230         0 (>= gnus-button-message-level 0) gnus-url-mailto 1)
6231        ("^[^:]+:" "\\(<\\(url: \\)?\\(nntp\\|news\\):\\([^>\n ]*\\)>\\)"
6232         1 (>= gnus-button-message-level 0) gnus-button-message-id 4))
6233    "*Alist of headers and regexps to match buttons in article heads.    "*Alist of headers and regexps to match buttons in article heads.
6234    
6235  This alist is very similar to `gnus-button-alist', except that each  This alist is very similar to `gnus-button-alist', except that each
# Line 4338  HEADER is a regexp to match a header.  F Line 6242  HEADER is a regexp to match a header.  F
6242    :group 'gnus-article-buttons    :group 'gnus-article-buttons
6243    :group 'gnus-article-headers    :group 'gnus-article-headers
6244    :type '(repeat (list (regexp :tag "Header")    :type '(repeat (list (regexp :tag "Header")
6245                         regexp                         (choice regexp variable)
6246                         (integer :tag "Button")                         (integer :tag "Button")
6247                         (sexp :tag "Form")                         (sexp :tag "Form")
6248                         (function :tag "Callback")                         (function :tag "Callback")
# Line 4362  call it with the value of the `gnus-data Line 6266  call it with the value of the `gnus-data
6266    (interactive "e")    (interactive "e")
6267    (set-buffer (window-buffer (posn-window (event-start event))))    (set-buffer (window-buffer (posn-window (event-start event))))
6268    (let* ((pos (posn-point (event-start event)))    (let* ((pos (posn-point (event-start event)))
6269           (data (get-text-property pos 'gnus-data))           (data (get-text-property pos 'gnus-data))
6270           (fun (get-text-property pos 'gnus-callback)))           (fun (get-text-property pos 'gnus-callback)))
6271      (goto-char pos)      (goto-char pos)
6272      (when fun      (when fun
# Line 4373  call it with the value of the `gnus-data Line 6277  call it with the value of the `gnus-data
6277  If the text at point has a `gnus-callback' property,  If the text at point has a `gnus-callback' property,
6278  call it with the value of the `gnus-data' text property."  call it with the value of the `gnus-data' text property."
6279    (interactive)    (interactive)
6280    (let* ((data (get-text-property (point) 'gnus-data))    (let ((data (get-text-property (point) 'gnus-data))
6281           (fun (get-text-property (point) 'gnus-callback)))          (fun (get-text-property (point) 'gnus-callback)))
6282      (when fun      (when fun
6283        (funcall fun data))))        (funcall fun data))))
6284    
# Line 4493  specified by `gnus-button-alist'." Line 6397  specified by `gnus-button-alist'."
6397        (article-goto-body)        (article-goto-body)
6398        (setq beg (point))        (setq beg (point))
6399        (while (setq entry (pop alist))        (while (setq entry (pop alist))
6400          (setq regexp (car entry))          (setq regexp (eval (car entry)))
6401          (goto-char beg)          (goto-char beg)
6402          (while (re-search-forward regexp nil t)          (while (re-search-forward regexp nil t)
6403            (let* ((start (and entry (match-beginning (nth 1 entry))))            (let* ((start (and entry (match-beginning (nth 1 entry))))
# Line 4535  specified by `gnus-button-alist'." Line 6439  specified by `gnus-button-alist'."
6439                                 (match-beginning 0))                                 (match-beginning 0))
6440                            (point-max)))                            (point-max)))
6441              (goto-char beg)              (goto-char beg)
6442              (while (re-search-forward (nth 1 entry) end t)              (while (re-search-forward (eval (nth 1 entry)) end t)
6443                ;; Each match within a header.                ;; Each match within a header.
6444                (let* ((entry (cdr entry))                (let* ((entry (cdr entry))
6445                       (start (match-beginning (nth 1 entry)))                       (start (match-beginning (nth 1 entry)))
# Line 4578  specified by `gnus-button-alist'." Line 6482  specified by `gnus-button-alist'."
6482      (let ((inhibit-read-only t)      (let ((inhibit-read-only t)
6483            (inhibit-point-motion-hooks t))            (inhibit-point-motion-hooks t))
6484        (if (text-property-any end (point-max) 'article-type 'signature)        (if (text-property-any end (point-max) 'article-type 'signature)
6485            (gnus-remove-text-properties-when            (progn
6486             'article-type 'signature end (point-max)              (gnus-delete-wash-type 'signature)
6487             (cons 'article-type (cons 'signature              (gnus-remove-text-properties-when
6488                                       gnus-hidden-properties)))               'article-type 'signature end (point-max)
6489                 (cons 'article-type (cons 'signature
6490                                           gnus-hidden-properties))))
6491            (gnus-add-wash-type 'signature)
6492          (gnus-add-text-properties-when          (gnus-add-text-properties-when
6493           'article-type nil end (point-max)           'article-type nil end (point-max)
6494           (cons 'article-type (cons 'signature           (cons 'article-type (cons 'signature
6495                                     gnus-hidden-properties)))))))                                     gnus-hidden-properties)))))
6496        (let ((gnus-article-mime-handle-alist-1 gnus-article-mime-handle-alist))
6497          (gnus-set-mode-line 'article))))
6498    
6499  (defun gnus-button-entry ()  (defun gnus-button-entry ()
6500    ;; Return the first entry in `gnus-button-alist' matching this place.    ;; Return the first entry in `gnus-button-alist' matching this place.
# Line 4593  specified by `gnus-button-alist'." Line 6502  specified by `gnus-button-alist'."
6502          (entry nil))          (entry nil))
6503      (while alist      (while alist
6504        (setq entry (pop alist))        (setq entry (pop alist))
6505        (if (looking-at (car entry))        (if (looking-at (eval (car entry)))
6506            (setq alist nil)            (setq alist nil)
6507          (setq entry nil)))          (setq entry nil)))
6508      entry))      entry))
# Line 4621  specified by `gnus-button-alist'." Line 6530  specified by `gnus-button-alist'."
6530          (gnus-message 1 "You must define `%S' to use this button"          (gnus-message 1 "You must define `%S' to use this button"
6531                        (cons fun args)))))))                        (cons fun args)))))))
6532    
6533    (defun gnus-parse-news-url (url)
6534      (let (scheme server group message-id articles)
6535        (with-temp-buffer
6536          (insert url)
6537          (goto-char (point-min))
6538          (when (looking-at "\\([A-Za-z]+\\):")
6539            (setq scheme (match-string 1))
6540            (goto-char (match-end 0)))
6541          (when (looking-at "//\\([^/]+\\)/")
6542            (setq server (match-string 1))
6543            (goto-char (match-end 0)))
6544    
6545          (cond
6546           ((looking-at "\\(.*@.*\\)")
6547            (setq message-id (match-string 1)))
6548           ((looking-at "\\([^/]+\\)/\\([-0-9]+\\)")
6549            (setq group (match-string 1)
6550                  articles (split-string (match-string 2) "-")))
6551           ((looking-at "\\([^/]+\\)/?")
6552            (setq group (match-string 1)))
6553           (t
6554            (error "Unknown news URL syntax"))))
6555        (list scheme server group message-id articles)))
6556    
6557    (defun gnus-button-handle-news (url)
6558      "Fetch a news URL."
6559      (destructuring-bind (scheme server group message-id articles)
6560          (gnus-parse-news-url url)
6561        (cond
6562         (message-id
6563          (save-excursion
6564            (set-buffer gnus-summary-buffer)
6565            (if server
6566                (let ((gnus-refer-article-method (list (list 'nntp server))))
6567                  (gnus-summary-refer-article message-id))
6568              (gnus-summary-refer-article message-id))))
6569         (group
6570          (gnus-button-fetch-group url)))))
6571    
6572    (defun gnus-button-handle-man (url)
6573      "Fetch a man page."
6574      (funcall gnus-button-man-handler url))
6575    
6576    (defun gnus-button-handle-info-url (url)
6577      "Fetch an info URL."
6578      (setq url (mm-subst-char-in-string ?+ ?\  url))
6579      (cond
6580       ((string-match "^\\([^:/]+\\)?/\\(.*\\)" url)
6581        (gnus-info-find-node
6582         (concat "(" (or (gnus-url-unhex-string (match-string 1 url))
6583                         "Gnus")
6584                 ")" (gnus-url-unhex-string (match-string 2 url)))))
6585       ((string-match "([^)\"]+)[^\"]+" url)
6586        (setq url
6587              (gnus-replace-in-string
6588               (gnus-replace-in-string url "[\n\t ]+" " ") "\"" ""))
6589        (gnus-info-find-node url))
6590       (t (error "Can't parse %s" url))))
6591    
6592    (defun gnus-button-handle-info-url-gnome (url)
6593      "Fetch GNOME style info URL."
6594      (setq url (mm-subst-char-in-string ?_ ?\  url))
6595      (if (string-match "\\([^#]+\\)#?\\(.*\\)" url)
6596          (gnus-info-find-node
6597           (concat "("
6598                   (gnus-url-unhex-string
6599                     (match-string 1 url))
6600                   ")"
6601                   (or (gnus-url-unhex-string
6602                        (match-string 2 url))
6603                       "Top")))
6604        (error "Can't parse %s" url)))
6605    
6606    (defun gnus-button-handle-info-url-kde (url)
6607      "Fetch KDE style info URL."
6608      (gnus-info-find-node (gnus-url-unhex-string url)))
6609    
6610    (defun gnus-button-handle-info-keystrokes (url)
6611      "Call `info' when pushing the corresponding URL button."
6612      ;; For links like `C-h i d m gnus RET', `C-h i d m CC Mode RET'.
6613      (info)
6614      (Info-directory)
6615      (Info-menu url))
6616    
6617  (defun gnus-button-message-id (message-id)  (defun gnus-button-message-id (message-id)
6618    "Fetch MESSAGE-ID."    "Fetch MESSAGE-ID."
6619    (save-excursion    (save-excursion
# Line 4632  specified by `gnus-button-alist'." Line 6625  specified by `gnus-button-alist'."
6625    (if (not (string-match "[:/]" address))    (if (not (string-match "[:/]" address))
6626        ;; This is just a simple group url.        ;; This is just a simple group url.
6627        (gnus-group-read-ephemeral-group address gnus-select-method)        (gnus-group-read-ephemeral-group address gnus-select-method)
6628      (if (not (string-match "^\\([^:/]+\\)\\(:\\([^/]+\\)/\\)?\\(.*\\)$"      (if (not
6629                             address))           (string-match
6630              "^\\([^:/]+\\)\\(:\\([^/]+\\)\\)?/\\([^/]+\\)\\(/\\([0-9]+\\)\\)?"
6631              address))
6632          (error "Can't parse %s" address)          (error "Can't parse %s" address)
6633        (gnus-group-read-ephemeral-group        (gnus-group-read-ephemeral-group
6634         (match-string 4 address)         (match-string 4 address)
# Line 4641  specified by `gnus-button-alist'." Line 6636  specified by `gnus-button-alist'."
6636                (nntp-address ,(match-string 1 address))                (nntp-address ,(match-string 1 address))
6637                (nntp-port-number ,(if (match-end 3)                (nntp-port-number ,(if (match-end 3)
6638                                       (match-string 3 address)                                       (match-string 3 address)
6639                                     "nntp")))))))                                     "nntp")))
6640           nil nil nil
6641           (and (match-end 6) (list (string-to-int (match-string 6 address))))))))
6642    
6643  (defun gnus-url-parse-query-string (query &optional downcase)  (defun gnus-url-parse-query-string (query &optional downcase)
6644    (let (retval pairs cur key val)    (let (retval pairs cur key val)
6645      (setq pairs (split-string query "&"))      (setq pairs (split-string query "&"))
6646      (while pairs      (while pairs
6647        (setq cur (car pairs)        (setq cur (car pairs)
6648              pairs (cdr pairs))              pairs (cdr pairs))
6649        (if (not (string-match "=" cur))        (if (not (string-match "=" cur))
6650            nil                           ; Grace            nil                           ; Grace
6651          (setq key (gnus-url-unhex-string (substring cur 0 (match-beginning 0)))          (setq key (gnus-url-unhex-string (substring cur 0 (match-beginning 0)))
6652                val (gnus-url-unhex-string (substring cur (match-end 0) nil)))                val (gnus-url-unhex-string (substring cur (match-end 0) nil) t))
6653          (if downcase          (if downcase
6654              (setq key (downcase key)))              (setq key (downcase key)))
6655          (setq cur (assoc key retval))          (setq cur (assoc key retval))
6656          (if cur          (if cur
6657              (setcdr cur (cons val (cdr cur)))              (setcdr cur (cons val (cdr cur)))
6658            (setq retval (cons (list key val) retval)))))            (setq retval (cons (list key val) retval)))))
6659      retval))      retval))
6660    
 (defun gnus-url-unhex (x)  
   (if (> x ?9)  
       (if (>= x ?a)  
           (+ 10 (- x ?a))  
         (+ 10 (- x ?A)))  
     (- x ?0)))  
   
 (defun gnus-url-unhex-string (str &optional allow-newlines)  
   "Remove %XXX embedded spaces, etc in a url.  
 If optional second argument ALLOW-NEWLINES is non-nil, then allow the  
 decoding of carriage returns and line feeds in the string, which is normally  
 forbidden in URL encoding."  
   (setq str (or str ""))  
   (let ((tmp "")  
         (case-fold-search t))  
     (while (string-match "%[0-9a-f][0-9a-f]" str)  
       (let* ((start (match-beginning 0))  
              (ch1 (gnus-url-unhex (elt str (+ start 1))))  
              (code (+ (* 16 ch1)  
                       (gnus-url-unhex (elt str (+ start 2))))))  
         (setq tmp (concat  
                    tmp (substring str 0 start)  
                    (cond  
                     (allow-newlines  
                      (char-to-string code))  
                     ((or (= code ?\n) (= code ?\r))  
                      " ")  
                     (t (char-to-string code))))  
               str (substring str (match-end 0)))))  
     (setq tmp (concat tmp str))  
     tmp))  
   
6661  (defun gnus-url-mailto (url)  (defun gnus-url-mailto (url)
6662    ;; Send mail to someone    ;; Send mail to someone
6663    (when (string-match "mailto:/*\\(.*\\)" url)    (when (string-match "mailto:/*\\(.*\\)" url)
6664      (setq url (substring url (match-beginning 1) nil)))      (setq url (substring url (match-beginning 1) nil)))
6665    (let (to args subject func)    (let (to args subject func)
6666      (if (string-match (regexp-quote "?") url)      (setq args (gnus-url-parse-query-string
6667          (setq to (gnus-url-unhex-string (substring url 0 (match-beginning 0)))                  (if (string-match "^\\?" url)
6668                args (gnus-url-parse-query-string                      (substring url 1)
6669                      (substring url (match-end 0) nil) t))                    (if (string-match "^\\([^?]+\\)\\?\\(.*\\)" url)
6670        (setq to (gnus-url-unhex-string url)))                        (concat "to=" (match-string 1 url) "&"
6671      (setq args (cons (list "to" to) args)                                (match-string 2 url))
6672            subject (cdr-safe (assoc "subject" args)))                      (concat "to=" url)))
6673      (message-mail)                  t)
6674              subject (cdr-safe (assoc "subject" args)))
6675        (gnus-msg-mail)
6676      (while args      (while args
6677        (setq func (intern-soft (concat "message-goto-" (downcase (caar args)))))        (setq func (intern-soft (concat "message-goto-" (downcase (caar args)))))
6678        (if (fboundp func)        (if (fboundp func)
6679            (funcall func)            (funcall func)
6680          (message-position-on-field (caar args)))          (message-position-on-field (caar args)))
6681        (insert (mapconcat 'identity (cdar args) ", "))        (insert (gnus-replace-in-string
6682                   (mapconcat 'identity (reverse (cdar args)) ", ")
6683                   "\r\n" "\n" t))
6684        (setq args (cdr args)))        (setq args (cdr args)))
6685      (if subject      (if subject
6686          (message-goto-body)          (message-goto-body)
6687        (message-goto-subject))))        (message-goto-subject))))
6688    
 (defun gnus-button-mailto (address)  
   "Mail to ADDRESS."  
   (set-buffer (gnus-copy-article-buffer))  
   (message-reply address))  
   
 (defalias 'gnus-button-reply 'message-reply)  
   
6689  (defun gnus-button-embedded-url (address)  (defun gnus-button-embedded-url (address)
6690    "Activate ADDRESS with `browse-url'."    "Activate ADDRESS with `browse-url'."
6691    (browse-url (gnus-strip-whitespace address)))    (browse-url (gnus-strip-whitespace address)))
# Line 4733  forbidden in URL encoding." Line 6695  forbidden in URL encoding."
6695  (defvar gnus-next-page-line-format "%{%(Next page...%)%}\n")  (defvar gnus-next-page-line-format "%{%(Next page...%)%}\n")
6696  (defvar gnus-prev-page-line-format "%{%(Previous page...%)%}\n")  (defvar gnus-prev-page-line-format "%{%(Previous page...%)%}\n")
6697    
6698  (defvar gnus-prev-page-map nil)  (defvar gnus-prev-page-map
6699  (unless gnus-prev-page-map    (let ((map (make-sparse-keymap)))
6700    (setq gnus-prev-page-map (make-sparse-keymap))      (unless (>= emacs-major-version 21)
6701    (define-key gnus-prev-page-map gnus-mouse-2 'gnus-button-prev-page)        ;; XEmacs doesn't care.
6702    (define-key gnus-prev-page-map "\r" 'gnus-button-prev-page))        (set-keymap-parent map gnus-article-mode-map))
6703        (define-key map gnus-mouse-2 'gnus-button-prev-page)
6704        (define-key map "\r" 'gnus-button-prev-page)
6705        map))
6706    
6707    (defvar gnus-next-page-map
6708      (let ((map (make-sparse-keymap)))
6709        (unless (>= emacs-major-version 21)
6710          ;; XEmacs doesn't care.
6711          (set-keymap-parent map gnus-article-mode-map))
6712        (define-key map gnus-mouse-2 'gnus-button-next-page)
6713        (define-key map "\r" 'gnus-button-next-page)
6714        map))
6715    
6716  (defun gnus-insert-prev-page-button ()  (defun gnus-insert-prev-page-button ()
6717    (let ((inhibit-read-only t))    (let ((b (point))
6718            (inhibit-read-only t))
6719      (gnus-eval-format      (gnus-eval-format
6720       gnus-prev-page-line-format nil       gnus-prev-page-line-format nil
6721       `(gnus-prev t local-map ,gnus-prev-page-map       `(,@(gnus-local-map-property gnus-prev-page-map)
6722                   gnus-callback gnus-article-button-prev-page           gnus-prev t
6723                   article-type annotation))))           gnus-callback gnus-article-button-prev-page
6724             article-type annotation))
6725  (defvar gnus-next-page-map nil)      (widget-convert-button
6726  (unless gnus-next-page-map       'link b (if (bolp)
6727    (setq gnus-next-page-map (make-keymap))                   ;; Exclude a newline.
6728    (suppress-keymap gnus-prev-page-map)                   (1- (point))
6729    (define-key gnus-next-page-map gnus-mouse-2 'gnus-button-next-page)                 (point))
6730    (define-key gnus-next-page-map "\r" 'gnus-button-next-page))       :action 'gnus-button-prev-page
6731         :button-keymap gnus-prev-page-map)))
6732    
6733  (defun gnus-button-next-page ()  (defun gnus-button-next-page (&optional args more-args)
6734    "Go to the next page."    "Go to the next page."
6735    (interactive)    (interactive)
6736    (let ((win (selected-window)))    (let ((win (selected-window)))
6737      (select-window (get-buffer-window gnus-article-buffer t))      (select-window (gnus-get-buffer-window gnus-article-buffer t))
6738      (gnus-article-next-page)      (gnus-article-next-page)
6739      (select-window win)))      (select-window win)))
6740    
6741  (defun gnus-button-prev-page ()  (defun gnus-button-prev-page (&optional args more-args)
6742    "Go to the prev page."    "Go to the prev page."
6743    (interactive)    (interactive)
6744    (let ((win (selected-window)))    (let ((win (selected-window)))
6745      (select-window (get-buffer-window gnus-article-buffer t))      (select-window (gnus-get-buffer-window gnus-article-buffer t))
6746      (gnus-article-prev-page)      (gnus-article-prev-page)
6747      (select-window win)))      (select-window win)))
6748    
6749  (defun gnus-insert-next-page-button ()  (defun gnus-insert-next-page-button ()
6750    (let ((inhibit-read-only t))    (let ((b (point))
6751            (inhibit-read-only t))
6752      (gnus-eval-format gnus-next-page-line-format nil      (gnus-eval-format gnus-next-page-line-format nil
6753                        `(gnus-next                        `(,@(gnus-local-map-property gnus-next-page-map)
6754                          t local-map ,gnus-next-page-map                            gnus-next t
6755                          gnus-callback gnus-article-button-next-page                            gnus-callback gnus-article-button-next-page
6756                          article-type annotation))))                            article-type annotation))
6757        (widget-convert-button
6758         'link b (if (bolp)
6759                     ;; Exclude a newline.
6760                     (1- (point))
6761                   (point))
6762         :action 'gnus-button-next-page
6763         :button-keymap gnus-next-page-map)))
6764    
6765  (defun gnus-article-button-next-page (arg)  (defun gnus-article-button-next-page (arg)
6766    "Go to the next page."    "Go to the next page."
6767    (interactive "P")    (interactive "P")
6768    (let ((win (selected-window)))    (let ((win (selected-window)))
6769      (select-window (get-buffer-window gnus-article-buffer t))      (select-window (gnus-get-buffer-window gnus-article-buffer t))
6770      (gnus-article-next-page)      (gnus-article-next-page)
6771      (select-window win)))      (select-window win)))
6772    
# Line 4790  forbidden in URL encoding." Line 6774  forbidden in URL encoding."
6774    "Go to the prev page."    "Go to the prev page."
6775    (interactive "P")    (interactive "P")
6776    (let ((win (selected-window)))    (let ((win (selected-window)))
6777      (select-window (get-buffer-window gnus-article-buffer t))      (select-window (gnus-get-buffer-window gnus-article-buffer t))
6778      (gnus-article-prev-page)      (gnus-article-prev-page)
6779      (select-window win)))      (select-window win)))
6780    
# Line 4800  forbidden in URL encoding." Line 6784  forbidden in URL encoding."
6784    
6785  This variable is a list of FUNCTION or (REGEXP . FUNCTION).  If item  This variable is a list of FUNCTION or (REGEXP . FUNCTION).  If item
6786  is FUNCTION, FUNCTION will be applied to all newsgroups.  If item is a  is FUNCTION, FUNCTION will be applied to all newsgroups.  If item is a
6787  \(REGEXP . FUNCTION), FUNCTION will be only applied to these newsgroups  \(REGEXP . FUNCTION), FUNCTION will be only apply to the newsgroups
6788  whose names match REGEXP.  whose names match REGEXP.
6789    
6790  For example:  For example:
# Line 4850  For example: Line 6834  For example:
6834          (highlightp (gnus-visual-p 'article-highlight 'highlight))          (highlightp (gnus-visual-p 'article-highlight 'highlight))
6835          val elem)          val elem)
6836      (gnus-run-hooks 'gnus-part-display-hook)      (gnus-run-hooks 'gnus-part-display-hook)
6837      (while (setq elem (pop alist))      (dolist (elem alist)
6838        (setq val        (setq val
6839              (save-excursion              (save-excursion
6840                (if (gnus-buffer-live-p gnus-summary-buffer)                (when (gnus-buffer-live-p gnus-summary-buffer)
6841                    (set-buffer gnus-summary-buffer))                  (set-buffer gnus-summary-buffer))
6842                (symbol-value (car elem))))                (symbol-value (car elem))))
6843        (when (and (or (consp val)        (when (and (or (consp val)
6844                       treated-type)                       treated-type)
# Line 4876  For example: Line 6860  For example:
6860    (cond    (cond
6861     ((null val)     ((null val)
6862      nil)      nil)
6863       (condition
6864        (eq condition val))
6865     ((and (listp val)     ((and (listp val)
6866           (stringp (car val)))           (stringp (car val)))
6867      (apply 'gnus-or (mapcar `(lambda (s)      (apply 'gnus-or (mapcar `(lambda (s)
# Line 4894  For example: Line 6880  For example:
6880          (equal (car val) type))          (equal (car val) type))
6881         (t         (t
6882          (error "%S is not a valid predicate" pred)))))          (error "%S is not a valid predicate" pred)))))
    (condition  
     (eq condition val))  
6883     ((eq val t)     ((eq val t)
6884      t)      t)
6885     ((eq val 'head)     ((eq val 'head)
# Line 4907  For example: Line 6891  For example:
6891     (t     (t
6892      (error "%S is not a valid value" val))))      (error "%S is not a valid value" val))))
6893    
6894    (defun gnus-article-encrypt-body (protocol &optional n)
6895      "Encrypt the article body."
6896      (interactive
6897       (list
6898        (or gnus-article-encrypt-protocol
6899            (completing-read "Encrypt protocol: "
6900                             gnus-article-encrypt-protocol-alist
6901                             nil t))
6902        current-prefix-arg))
6903      (let ((func (cdr (assoc protocol gnus-article-encrypt-protocol-alist))))
6904        (unless func
6905          (error (format "Can't find the encrypt protocol %s" protocol)))
6906        (if (member gnus-newsgroup-name '("nndraft:delayed"
6907                                          "nndraft:drafts"
6908                                          "nndraft:queue"))
6909            (error "Can't encrypt the article in group %s"
6910                   gnus-newsgroup-name))
6911        (gnus-summary-iterate n
6912          (save-excursion
6913            (set-buffer gnus-summary-buffer)
6914            (let ((mail-parse-charset gnus-newsgroup-charset)
6915                  (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets)
6916                  (summary-buffer gnus-summary-buffer)
6917                  references point)
6918              (gnus-set-global-variables)
6919              (when (gnus-group-read-only-p)
6920                (error "The current newsgroup does not support article encrypt"))
6921              (gnus-summary-show-article t)
6922              (setq references
6923                  (or (mail-header-references gnus-current-headers) ""))
6924              (set-buffer gnus-article-buffer)
6925              (let* ((inhibit-read-only t)
6926                     (headers
6927                      (mapcar (lambda (field)
6928                                (and (save-restriction
6929                                       (message-narrow-to-head)
6930                                       (goto-char (point-min))
6931                                       (search-forward field nil t))
6932                                     (prog2
6933                                         (message-narrow-to-field)
6934                                         (buffer-string)
6935                                       (delete-region (point-min) (point-max))
6936                                       (widen))))
6937                              '("Content-Type:" "Content-Transfer-Encoding:"
6938                                "Content-Disposition:"))))
6939                (message-narrow-to-head)
6940                (message-remove-header "MIME-Version")
6941                (goto-char (point-max))
6942                (setq point (point))
6943                (insert (apply 'concat headers))
6944                (widen)
6945                (narrow-to-region point (point-max))
6946                (let ((message-options message-options))
6947                  (message-options-set 'message-sender user-mail-address)
6948                  (message-options-set 'message-recipients user-mail-address)
6949                  (message-options-set 'message-sign-encrypt 'not)
6950                  (funcall func))
6951                (goto-char (point-min))
6952                (insert "MIME-Version: 1.0\n")
6953                (widen)
6954                (gnus-summary-edit-article-done
6955                 references nil summary-buffer t))
6956              (when gnus-keep-backlog
6957                (gnus-backlog-remove-article
6958                 (car gnus-article-current) (cdr gnus-article-current)))
6959              (save-excursion
6960                (when (get-buffer gnus-original-article-buffer)
6961                  (set-buffer gnus-original-article-buffer)
6962                  (setq gnus-original-article nil)))
6963              (when gnus-use-cache
6964                (gnus-cache-update-article
6965                 (car gnus-article-current) (cdr gnus-article-current))))))))
6966    
6967    (defvar gnus-mime-security-button-line-format "%{%([[%t:%i]%D]%)%}\n"
6968      "The following specs can be used:
6969    %t  The security MIME type
6970    %i  Additional info
6971    %d  Details
6972    %D  Details if button is pressed")
6973    
6974    (defvar gnus-mime-security-button-end-line-format "%{%([[End of %t]%D]%)%}\n"
6975      "The following specs can be used:
6976    %t  The security MIME type
6977    %i  Additional info
6978    %d  Details
6979    %D  Details if button is pressed")
6980    
6981    (defvar gnus-mime-security-button-line-format-alist
6982      '((?t gnus-tmp-type ?s)
6983        (?i gnus-tmp-info ?s)
6984        (?d gnus-tmp-details ?s)
6985        (?D gnus-tmp-pressed-details ?s)))
6986    
6987    (defvar gnus-mime-security-button-map
6988      (let ((map (make-sparse-keymap)))
6989        (unless (>= (string-to-number emacs-version) 21)
6990          (set-keymap-parent map gnus-article-mode-map))
6991        (define-key map gnus-mouse-2 'gnus-article-push-button)
6992        (define-key map "\r" 'gnus-article-press-button)
6993        map))
6994    
6995    (defvar gnus-mime-security-details-buffer nil)
6996    
6997    (defvar gnus-mime-security-button-pressed nil)
6998    
6999    (defvar gnus-mime-security-show-details-inline t
7000      "If non-nil, show details in the article buffer.")
7001    
7002    (defun gnus-mime-security-verify-or-decrypt (handle)
7003      (mm-remove-parts (cdr handle))
7004      (let ((region (mm-handle-multipart-ctl-parameter handle 'gnus-region))
7005            point (inhibit-read-only t))
7006        (if region
7007            (goto-char (car region)))
7008        (save-restriction
7009          (narrow-to-region (point) (point))
7010          (with-current-buffer (mm-handle-multipart-original-buffer handle)
7011            (let* ((mm-verify-option 'known)
7012                   (mm-decrypt-option 'known)
7013                   (nparts (mm-possibly-verify-or-decrypt (cdr handle) handle)))
7014              (unless (eq nparts (cdr handle))
7015                (mm-destroy-parts (cdr handle))
7016                (setcdr handle nparts))))
7017          (setq point (point))
7018          (gnus-mime-display-security handle)
7019          (goto-char (point-max)))
7020        (when region
7021          (delete-region (point) (cdr region))
7022          (set-marker (car region) nil)
7023          (set-marker (cdr region) nil))
7024        (goto-char point)))
7025    
7026    (defun gnus-mime-security-show-details (handle)
7027      (let ((details (mm-handle-multipart-ctl-parameter handle 'gnus-details)))
7028        (if (not details)
7029            (gnus-message 5 "No details.")
7030          (if gnus-mime-security-show-details-inline
7031              (let ((gnus-mime-security-button-pressed
7032                     (not (get-text-property (point) 'gnus-mime-details)))
7033                    (gnus-mime-security-button-line-format
7034                     (get-text-property (point) 'gnus-line-format))
7035                    (inhibit-read-only t))
7036                (forward-char -1)
7037                (while (eq (get-text-property (point) 'gnus-line-format)
7038                           gnus-mime-security-button-line-format)
7039                  (forward-char -1))
7040                (forward-char)
7041                (save-restriction
7042                  (narrow-to-region (point) (point))
7043                  (gnus-insert-mime-security-button handle))
7044                (delete-region (point)
7045                               (or (text-property-not-all
7046                                    (point) (point-max)
7047                                    'gnus-line-format
7048                                    gnus-mime-security-button-line-format)
7049                                   (point-max))))
7050            ;; Not inlined.
7051            (if (gnus-buffer-live-p gnus-mime-security-details-buffer)
7052                (with-current-buffer gnus-mime-security-details-buffer
7053                  (erase-buffer)
7054                  t)
7055              (setq gnus-mime-security-details-buffer
7056                    (gnus-get-buffer-create "*MIME Security Details*")))
7057            (with-current-buffer gnus-mime-security-details-buffer
7058              (insert details)
7059              (goto-char (point-min)))
7060            (pop-to-buffer gnus-mime-security-details-buffer)))))
7061    
7062    (defun gnus-mime-security-press-button (handle)
7063      (save-excursion
7064        (if (mm-handle-multipart-ctl-parameter handle 'gnus-info)
7065            (gnus-mime-security-show-details handle)
7066          (gnus-mime-security-verify-or-decrypt handle))))
7067    
7068    (defun gnus-insert-mime-security-button (handle &optional displayed)
7069      (let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol))
7070             (gnus-tmp-type
7071              (concat
7072               (or (nth 2 (assoc protocol mm-verify-function-alist))
7073                   (nth 2 (assoc protocol mm-decrypt-function-alist))
7074                   "Unknown")
7075               (if (equal (car handle) "multipart/signed")
7076                   " Signed" " Encrypted")
7077               " Part"))
7078             (gnus-tmp-info
7079              (or (mm-handle-multipart-ctl-parameter handle 'gnus-info)
7080                  "Undecided"))
7081             (gnus-tmp-details
7082              (mm-handle-multipart-ctl-parameter handle 'gnus-details))
7083             gnus-tmp-pressed-details
7084             b e)
7085        (setq gnus-tmp-details
7086              (if gnus-tmp-details
7087                  (concat "\n" gnus-tmp-details)
7088                ""))
7089        (setq gnus-tmp-pressed-details
7090              (if gnus-mime-security-button-pressed gnus-tmp-details ""))
7091        (unless (bolp)
7092          (insert "\n"))
7093        (setq b (point))
7094        (gnus-eval-format
7095         gnus-mime-security-button-line-format
7096         gnus-mime-security-button-line-format-alist
7097         `(,@(gnus-local-map-property gnus-mime-security-button-map)
7098             gnus-callback gnus-mime-security-press-button
7099             gnus-line-format ,gnus-mime-security-button-line-format
7100             gnus-mime-details ,gnus-mime-security-button-pressed
7101             article-type annotation
7102             gnus-data ,handle))
7103        (setq e (if (bolp)
7104                    ;; Exclude a newline.
7105                    (1- (point))
7106                  (point)))
7107        (widget-convert-button
7108         'link b e
7109         :mime-handle handle
7110         :action 'gnus-widget-press-button
7111         :button-keymap gnus-mime-security-button-map
7112         :help-echo
7113         (lambda (widget/window &optional overlay pos)
7114           ;; Needed to properly clear the message due to a bug in
7115           ;; wid-edit (XEmacs only).
7116           (when (boundp 'help-echo-owns-message)
7117             (setq help-echo-owns-message t))
7118           (format
7119            "%S: show detail"
7120            (aref gnus-mouse-2 0))))))
7121    
7122    (defun gnus-mime-display-security (handle)
7123      (save-restriction
7124        (narrow-to-region (point) (point))
7125        (unless (gnus-unbuttonized-mime-type-p (car handle))
7126          (gnus-insert-mime-security-button handle))
7127        (gnus-mime-display-mixed (cdr handle))
7128        (unless (bolp)
7129          (insert "\n"))
7130        (unless (gnus-unbuttonized-mime-type-p (car handle))
7131          (let ((gnus-mime-security-button-line-format
7132                 gnus-mime-security-button-end-line-format))
7133            (gnus-insert-mime-security-button handle)))
7134        (mm-set-handle-multipart-parameter
7135         handle 'gnus-region
7136         (cons (set-marker (make-marker) (point-min))
7137               (set-marker (make-marker) (point-max))))))
7138    
7139  (gnus-ems-redefine)  (gnus-ems-redefine)
7140    
7141  (provide 'gnus-art)  (provide 'gnus-art)

Legend:
Removed from v.1.41.2.3  
changed lines
  Added in v.1.41.2.4

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26