;;; gnus-art.el --- article mode commands for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
(require 'gnus-sum)
(require 'gnus-spec)
(require 'gnus-int)
+(require 'gnus-win)
(require 'mm-bodies)
(require 'mail-parse)
(require 'mm-decode)
"^X-UIDL:" "^MIME-Version:" "^Return-Path:" "^In-Reply-To:"
"^Content-Type:" "^Content-Transfer-Encoding:" "^X-WebTV-Signature:"
"^X-MimeOLE:" "^X-MSMail-Priority:" "^X-Priority:" "^X-Loop:"
- "^X-Authentication-Warning:" "^X-MIME-Autoconverted:" "^X-Face:"
+ "^X-Authentication-Warning:" "^X-MIME-Autoconverted:" "^X-Face"
"^X-Attribution:" "^X-Originating-IP:" "^Delivered-To:"
"^NNTP-[-A-Za-z]+:" "^Distribution:" "^X-no-archive:" "^X-Trace:"
"^X-Complaints-To:" "^X-NNTP-Posting-Host:" "^X-Orig.*:"
"^X-Abuse-Info:" "^X-From_:" "^X-Accept-Language:" "^Errors-To:"
"^X-BeenThere:" "^X-Mailman-Version:" "^List-Help:" "^List-Post:"
"^List-Subscribe:" "^List-Id:" "^List-Unsubscribe:" "^List-Archive:"
- "^X-Content-length:" "^X-Posting-Agent:" "^Original-Received:")
+ "^X-Content-length:" "^X-Posting-Agent:" "^Original-Received:"
+ "^X-Request-PGP:" "^X-Fingerprint:" "^X-WRIEnvto:" "^X-WRIEnvfrom:"
+ "^X-Virus-Scanned:" "^X-Delivery-Agent:" "^Posted-Date:" "^X-Gateway:"
+ "^X-Local-Origin:" "^X-Local-Destination:" "^X-UserInfo1:"
+ "^X-Received-Date:")
"*All headers that start with this regexp will be hidden.
This variable can also be a list of regexps of headers to be ignored.
If `gnus-visible-headers' is non-nil, this variable will be ignored."
;; non-graphical frames in a session.
(defcustom gnus-article-x-face-command
(if (featurep 'xemacs)
- (if (or (featurep 'xface)
- (featurep 'xpm))
- 'gnus-xmas-article-display-xface
+ (if (or (gnus-image-type-available-p 'xface)
+ (gnus-image-type-available-p 'pbm))
+ 'gnus-display-x-face-in-from
"{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | ee -")
- (if (and (fboundp 'image-type-available-p)
- (image-type-available-p 'xbm))
- 'gnus-article-display-xface
- (if gnus-article-compface-xbm
- "{ echo '/* Width=48, Height=48 */'; uncompface; } | display -"
- "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | \
-display -")))
+ (if (gnus-image-type-available-p 'pbm)
+ 'gnus-display-x-face-in-from
+ "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | \
+display -"))
"*String or function to be executed to display an X-Face header.
If it is a string, the command will be executed in a sub-shell
asynchronously. The compressed face will be piped to this command."
:type `(choice string
- (function-item
- ,(if (featurep 'xemacs)
- 'gnus-xmas-article-display-xface
- 'gnus-article-display-xface))
+ (function-item gnus-display-x-face-in-from)
function)
:version "21.1"
:group 'gnus-article-washing)
(defcustom gnus-emphasis-alist
(let ((format
- "\\(\\s-\\|^\\|[-\"]\\|\\s(\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\s-\\|[-,;:\"]\\s-\\|[?!.]+\\s-\\|\\s)\\)")
+ "\\(\\s-\\|^\\|\\=\\|[-\"]\\|\\s(\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\([-,.;:!?\"]\\|\\s)\\)+\\s-\\|[?!.]\\s-\\|\\s)\\|\\s-\\)")
(types
- '(("_" "_" underline)
+ '(("\\*" "\\*" bold)
+ ("_" "_" underline)
("/" "/" italic)
- ("\\*" "\\*" bold)
("_/" "/_" underline-italic)
("_\\*" "\\*_" underline-bold)
("\\*/" "/\\*" bold-italic)
("_\\*/" "/\\*_" underline-bold-italic))))
- `(("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)"
- 2 3 gnus-emphasis-underline)
- ,@(mapcar
+ `(,@(mapcar
(lambda (spec)
(list
(format format (car spec) (cadr spec))
2 3 (intern (format "gnus-emphasis-%s" (nth 2 spec)))))
- types)))
+ types)
+ ("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)"
+ 2 3 gnus-emphasis-underline)))
"*Alist that says how to fontify certain phrases.
Each item looks like this:
:group 'gnus-article-mime
:type '(repeat regexp))
+(defcustom gnus-body-boundary-delimiter "_"
+ "String used to delimit header and body.
+This variable is used by `gnus-article-treat-body-boundary' which can
+be controlled by `gnus-treat-body-boundary'."
+ :group 'gnus-article-various
+ :type '(choice (item :tag "None" :value nil)
+ string))
+
+(defcustom gnus-picon-databases '("/usr/lib/picon" "/usr/local/faces")
+ "*Defines the location of the faces database.
+For information on obtaining this database of pretty pictures, please
+see http://www.cs.indiana.edu/picons/ftp/index.html"
+ :type 'directory
+ :group 'gnus-picon)
+
+(defun gnus-picons-installed-p ()
+ "Say whether picons are installed on your machine."
+ (let ((installed nil))
+ (dolist (database gnus-picon-databases)
+ (when (file-exists-p database)
+ (setq installed t)))
+ installed))
+
(defcustom gnus-article-mime-part-function nil
"Function called with a MIME handle as the argument.
This is meant for people who want to do something automatic based
(defcustom gnus-treat-buttonize 100000
"Add buttons.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles'."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(put 'gnus-treat-buttonize 'highlight t)
(defcustom gnus-treat-buttonize-head 'head
"Add buttons to the head.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
:type gnus-article-treat-head-custom)
(put 'gnus-treat-buttonize-head 'highlight t)
50000)
"Emphasize text.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(put 'gnus-treat-emphasize 'highlight t)
(defcustom gnus-treat-strip-cr nil
"Remove carriage returns.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
+ :group 'gnus-article-treat
+ :type gnus-article-treat-custom)
+
+(defcustom gnus-treat-unsplit-urls nil
+ "Remove newlines from within URLs.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(defcustom gnus-treat-leading-whitespace nil
"Remove leading whitespace in headers.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(defcustom gnus-treat-hide-headers 'head
"Hide headers.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
:type gnus-article-treat-head-custom)
(defcustom gnus-treat-hide-boring-headers nil
"Hide boring headers.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
:type gnus-article-treat-head-custom)
(defcustom gnus-treat-hide-signature nil
"Hide the signature.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(defcustom gnus-treat-fill-article nil
"Fill the article.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(defcustom gnus-treat-hide-citation nil
"Hide cited text.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(defcustom gnus-treat-hide-citation-maybe nil
"Hide cited text.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(defcustom gnus-treat-strip-list-identifiers 'head
"Strip list identifiers from `gnus-list-identifiers`.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:version "21.1"
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(defcustom gnus-treat-strip-pgp t
"Strip PGP signatures.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(defcustom gnus-treat-strip-pem nil
"Strip PEM signatures.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
"Strip banners from articles.
The banner to be stripped is specified in the `banner' group parameter.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(defcustom gnus-treat-highlight-headers 'head
"Highlight the headers.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
:type gnus-article-treat-head-custom)
(put 'gnus-treat-highlight-headers 'highlight t)
(defcustom gnus-treat-highlight-citation t
"Highlight cited text.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(put 'gnus-treat-highlight-citation 'highlight t)
(defcustom gnus-treat-date-ut nil
"Display the Date in UT (GMT).
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
:type gnus-article-treat-head-custom)
(defcustom gnus-treat-date-local nil
"Display the Date in the local timezone.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
:type gnus-article-treat-head-custom)
(defcustom gnus-treat-date-english nil
"Display the Date in a format that can be read aloud in English.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
:type gnus-article-treat-head-custom)
(defcustom gnus-treat-date-lapsed nil
"Display the Date header in a way that says how much time has elapsed.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
:type gnus-article-treat-head-custom)
(defcustom gnus-treat-date-original nil
"Display the date in the original timezone.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
:type gnus-article-treat-head-custom)
(defcustom gnus-treat-date-iso8601 nil
"Display the date in the ISO8601 format.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:version "21.1"
:group 'gnus-article-treat
:type gnus-article-treat-head-custom)
"Display the date in a user-defined format.
The format is defined by the `gnus-article-time-format' variable.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
:type gnus-article-treat-head-custom)
(defcustom gnus-treat-strip-headers-in-body t
"Strip the X-No-Archive header line from the beginning of the body.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:version "21.1"
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(defcustom gnus-treat-strip-trailing-blank-lines nil
"Strip trailing blank lines.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(defcustom gnus-treat-strip-leading-blank-lines nil
"Strip leading blank lines.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(defcustom gnus-treat-strip-multiple-blank-lines nil
"Strip multiple blank lines.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
+ :group 'gnus-article-treat
+ :type gnus-article-treat-custom)
+
+(defcustom gnus-treat-unfold-headers 'head
+ "Unfold folded header lines.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See Info node `(gnus)Customizing Articles' for details."
+ :group 'gnus-article-treat
+ :type gnus-article-treat-custom)
+
+(defcustom gnus-treat-fold-headers nil
+ "Fold headers.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See Info node `(gnus)Customizing Articles' for details."
+ :group 'gnus-article-treat
+ :type gnus-article-treat-custom)
+
+(defcustom gnus-treat-fold-newsgroups 'head
+ "Fold the Newsgroups and Followup-To headers.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(defcustom gnus-treat-overstrike t
"Treat overstrike highlighting.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(put 'gnus-treat-overstrike 'highlight t)
(defcustom gnus-treat-display-xface
- (and (or (and (fboundp 'image-type-available-p)
+ (and (not noninteractive)
+ (or (and (fboundp 'image-type-available-p)
(image-type-available-p 'xbm)
(string-match "^0x" (shell-command-to-string "uncompface")))
- (and (featurep 'xemacs) (featurep 'xface)))
+ (and (featurep 'xemacs)
+ (featurep 'xface)))
'head)
"Display X-Face headers.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' and Info node
+`(gnus)X-Face' for details."
:group 'gnus-article-treat
:version "21.1"
:type gnus-article-treat-head-custom)
(put 'gnus-treat-display-xface 'highlight t)
+(defcustom gnus-treat-display-grey-xface
+ (and (not noninteractive)
+ (string-match "^0x" (shell-command-to-string "uncompface"))
+ t)
+ "Display grey X-Face headers.
+Valid values are nil, t."
+ :group 'gnus-article-treat
+ :version "21.3"
+ :type 'boolean)
+(put 'gnus-treat-display-grey-xface 'highlight t)
+
(defcustom gnus-treat-display-smileys
(if (or (and (featurep 'xemacs)
(featurep 'xpm))
t nil)
"Display smileys.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' and Info node
+`(gnus)Smileys' for details."
:group 'gnus-article-treat
:version "21.1"
:type gnus-article-treat-custom)
(put 'gnus-treat-display-smileys 'highlight t)
-(defcustom gnus-treat-display-picons (if (featurep 'xemacs) 'head nil)
- "Display picons.
+(defcustom gnus-treat-from-picon
+ (if (and (gnus-image-type-available-p 'xpm)
+ (gnus-picons-installed-p))
+ 'head nil)
+ "Display picons in the From header.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See Info node `(gnus)Customizing Articles' and Info node
+`(gnus)Picons' for details."
+ :group 'gnus-article-treat
+ :type gnus-article-treat-head-custom)
+(put 'gnus-treat-from-picon 'highlight t)
+
+(defcustom gnus-treat-mail-picon
+ (if (and (gnus-image-type-available-p 'xpm)
+ (gnus-picons-installed-p))
+ 'head nil)
+ "Display picons in To and Cc headers.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See Info node `(gnus)Customizing Articles' and Info node
+`(gnus)Picons' for details."
+ :group 'gnus-article-treat
+ :type gnus-article-treat-head-custom)
+(put 'gnus-treat-mail-picon 'highlight t)
+
+(defcustom gnus-treat-newsgroups-picon
+ (if (and (gnus-image-type-available-p 'xpm)
+ (gnus-picons-installed-p))
+ 'head nil)
+ "Display picons in the Newsgroups and Followup-To headers.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' and Info node
+`(gnus)Picons' for details."
:group 'gnus-article-treat
:type gnus-article-treat-head-custom)
-(put 'gnus-treat-display-picons 'highlight t)
+(put 'gnus-treat-newsgroups-picon 'highlight t)
+
+(defcustom gnus-treat-body-boundary
+ (if (or gnus-treat-newsgroups-picon
+ gnus-treat-mail-picon
+ gnus-treat-from-picon)
+ 'head nil)
+ "Draw a boundary at the end of the headers.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See Info node `(gnus)Customizing Articles' for details."
+ :version "21.1"
+ :group 'gnus-article-treat
+ :type gnus-article-treat-custom)
(defcustom gnus-treat-capitalize-sentences nil
"Capitalize sentence-starting words.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:version "21.1"
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(defcustom gnus-treat-fill-long-lines nil
"Fill long lines.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(defcustom gnus-treat-play-sounds nil
"Play sounds.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:version "21.1"
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(defcustom gnus-treat-translate nil
"Translate articles from one language to another.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:version "21.1"
:group 'gnus-article-treat
:type gnus-article-treat-custom)
"Verify X-PGP-Sig.
To automatically treat X-PGP-Sig, set it to head.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
:group 'mime-security
:type gnus-article-treat-custom)
:type 'string
:group 'mime-security)
+(defvar gnus-article-wash-function nil
+ "Function used for converting HTML into text.")
+
;;; Internal variables
(defvar gnus-english-month-names
(defvar article-goto-body-goes-to-point-min-p nil)
(defvar gnus-article-wash-types nil)
(defvar gnus-article-emphasis-alist nil)
+(defvar gnus-article-image-alist nil)
(defvar gnus-article-mime-handle-alist-1 nil)
(defvar gnus-treatment-function-alist
(gnus-treat-fill-article gnus-article-fill-cited-article)
(gnus-treat-fill-long-lines gnus-article-fill-long-lines)
(gnus-treat-strip-cr gnus-article-remove-cr)
- (gnus-treat-emphasize gnus-article-emphasize)
- (gnus-treat-display-xface gnus-article-display-x-face)
+ (gnus-treat-unsplit-urls gnus-article-unsplit-urls)
(gnus-treat-date-ut gnus-article-date-ut)
(gnus-treat-date-local gnus-article-date-local)
(gnus-treat-date-english gnus-article-date-english)
(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)
+ (gnus-treat-display-xface gnus-article-display-x-face)
(gnus-treat-hide-headers gnus-article-maybe-hide-headers)
(gnus-treat-hide-boring-headers gnus-article-hide-boring-headers)
(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)
(gnus-treat-strip-list-identifiers gnus-article-hide-list-identifiers)
(gnus-treat-leading-whitespace gnus-article-remove-leading-whitespace)
(gnus-treat-strip-pgp gnus-article-hide-pgp)
(gnus-treat-strip-pem gnus-article-hide-pem)
+ (gnus-treat-from-picon gnus-treat-from-picon)
+ (gnus-treat-mail-picon gnus-treat-mail-picon)
+ (gnus-treat-newsgroups-picon gnus-treat-newsgroups-picon)
(gnus-treat-highlight-headers gnus-article-highlight-headers)
- (gnus-treat-highlight-citation gnus-article-highlight-citation)
(gnus-treat-highlight-signature gnus-article-highlight-signature)
(gnus-treat-strip-trailing-blank-lines
gnus-article-remove-trailing-blank-lines)
(gnus-treat-strip-multiple-blank-lines
gnus-article-strip-multiple-blank-lines)
(gnus-treat-overstrike gnus-article-treat-overstrike)
+ (gnus-treat-unfold-headers gnus-article-treat-unfold-headers)
+ (gnus-treat-fold-headers gnus-article-treat-fold-headers)
+ (gnus-treat-fold-newsgroups gnus-article-treat-fold-newsgroups)
(gnus-treat-buttonize-head gnus-article-add-buttons-to-head)
- (gnus-treat-display-smileys gnus-smiley-display)
+ (gnus-treat-display-smileys gnus-treat-smiley)
(gnus-treat-capitalize-sentences gnus-article-capitalize-sentences)
- (gnus-treat-display-picons gnus-article-display-picons)
+ (gnus-treat-emphasize gnus-article-emphasize)
+ (gnus-treat-hide-citation gnus-article-hide-citation)
+ (gnus-treat-hide-citation-maybe gnus-article-hide-citation-maybe)
+ (gnus-treat-highlight-citation gnus-article-highlight-citation)
+ (gnus-treat-body-boundary gnus-article-treat-body-boundary)
(gnus-treat-play-sounds gnus-earcon-display)))
(defvar gnus-article-mime-handle-alist nil)
(defvar gnus-inhibit-hiding nil)
+;;; Macros for dealing with the article buffer.
+
+(defmacro gnus-with-article-headers (&rest forms)
+ `(save-excursion
+ (set-buffer gnus-article-buffer)
+ (save-restriction
+ (let ((buffer-read-only nil)
+ (inhibit-point-motion-hooks t)
+ (case-fold-search t))
+ (article-narrow-to-head)
+ ,@forms))))
+
+(put 'gnus-with-article-headers 'lisp-indent-function 0)
+(put 'gnus-with-article-headers 'edebug-form-spec '(body))
+
+(defmacro gnus-with-article-buffer (&rest forms)
+ `(save-excursion
+ (set-buffer gnus-article-buffer)
+ (let ((buffer-read-only nil))
+ ,@forms)))
+
+(put 'gnus-with-article-buffer 'lisp-indent-function 0)
+(put 'gnus-with-article-buffer 'edebug-form-spec '(body))
+
+(defun gnus-article-goto-header (header)
+ "Go to HEADER, which is a regular expression."
+ (re-search-forward (concat "^\\(" header "\\):") nil t))
+
(defsubst gnus-article-hide-text (b e props)
"Set text PROPS on the B to E region, extending `intangible' 1 past B."
(gnus-add-text-properties-when 'article-type nil b e props)
(defun gnus-article-hide-text-type (b e type)
"Hide text of TYPE between B and E."
- (push type gnus-article-wash-types)
+ (gnus-add-wash-type type)
(gnus-article-hide-text
b e (cons 'article-type (cons type gnus-hidden-properties))))
(defun gnus-article-unhide-text-type (b e type)
"Unhide text of TYPE between B and E."
- (setq gnus-article-wash-types
- (delq type gnus-article-wash-types))
+ (gnus-delete-wash-type type)
(remove-text-properties
b e (cons 'article-type (cons type gnus-hidden-properties)))
(when (memq 'intangible gnus-hidden-properties)
(when (setq beg (text-property-any
(point-min) (point-max) 'message-rank (+ 2 max)))
;; We delete the unwanted headers.
- (push 'headers gnus-article-wash-types)
+ (gnus-add-wash-type 'headers)
(add-text-properties (point-min) (+ 5 (point-min))
'(article-type headers dummy-invisible t))
(delete-region beg (point-max))))))))
(put-text-property
(point) (1+ (point)) 'face 'underline)))))))))
+(defun gnus-article-treat-unfold-headers ()
+ "Unfold folded message headers.
+Only the headers that fit into the current window width will be
+unfolded."
+ (interactive)
+ (gnus-with-article-headers
+ (let (length)
+ (while (not (eobp))
+ (save-restriction
+ (mail-header-narrow-to-field)
+ (let ((header (buffer-substring (point-min) (point-max))))
+ (with-temp-buffer
+ (insert header)
+ (goto-char (point-min))
+ (while (re-search-forward "\n[\t ]" nil t)
+ (replace-match " " t t)))
+ (setq length (- (point-max) (point-min) 1)))
+ (when (< length (window-width))
+ (while (re-search-forward "\n[\t ]" nil t)
+ (replace-match " " t t)))
+ (goto-char (point-max)))))))
+
+(defun gnus-article-treat-fold-headers ()
+ "Fold message headers."
+ (interactive)
+ (gnus-with-article-headers
+ (while (not (eobp))
+ (save-restriction
+ (mail-header-narrow-to-field)
+ (mail-header-fold-field)
+ (goto-char (point-max))))))
+
+(defun gnus-treat-smiley ()
+ "Toggle display of textual emoticons (\"smileys\") as small graphical icons."
+ (interactive)
+ (gnus-with-article-buffer
+ (if (memq 'smiley gnus-article-wash-types)
+ (gnus-delete-images 'smiley)
+ (article-goto-body)
+ (let ((images (smiley-region (point) (point-max))))
+ (when images
+ (gnus-add-wash-type 'smiley)
+ (dolist (image images)
+ (gnus-add-image 'smiley image)))))))
+
+(defun gnus-article-remove-images ()
+ "Remove all images from the article buffer."
+ (interactive)
+ (gnus-with-article-buffer
+ (dolist (elem gnus-article-image-alist)
+ (gnus-delete-images (car elem)))))
+
+(defun gnus-article-treat-fold-newsgroups ()
+ "Unfold folded message headers.
+Only the headers that fit into the current window width will be
+unfolded."
+ (interactive)
+ (gnus-with-article-headers
+ (while (gnus-article-goto-header "newsgroups\\|followup-to")
+ (save-restriction
+ (mail-header-narrow-to-field)
+ (while (re-search-forward ", *" nil t)
+ (replace-match ", " t t))
+ (mail-header-fold-field)
+ (goto-char (point-max))))))
+
+(defun gnus-article-treat-body-boundary ()
+ "Place a boundary line at the end of the headers."
+ (interactive)
+ (when (and gnus-body-boundary-delimiter
+ (> (length gnus-body-boundary-delimiter) 0))
+ (gnus-with-article-headers
+ (goto-char (point-max))
+ (let ((start (point)))
+ (insert "X-Boundary: ")
+ (gnus-add-text-properties start (point) '(invisible t intangible t))
+ (insert (let (str)
+ (while (>= (1- (window-width)) (length str))
+ (setq str (concat str gnus-body-boundary-delimiter)))
+ (substring str 0 (1- (window-width))))
+ "\n")
+ (gnus-add-text-properties start (point) '(gnus-decoration 'header))))))
+
(defun article-fill-long-lines ()
"Fill lines that are wider than the window width."
(interactive)
(defun article-display-x-face (&optional force)
"Look for an X-Face header and display it if present."
(interactive (list 'force))
- (save-excursion
- ;; Delete the old process, if any.
- (when (process-status "article-x-face")
- (delete-process "article-x-face"))
- (let ((inhibit-point-motion-hooks t)
- x-faces
- (case-fold-search t)
- from last)
- (save-restriction
- (article-narrow-to-head)
- (when (and buffer-read-only ;; When type `W f'
- (progn
- (goto-char (point-min))
- (not (re-search-forward "^X-Face:[\t ]*" nil t)))
- (gnus-buffer-live-p gnus-original-article-buffer))
- (with-current-buffer gnus-original-article-buffer
- (save-restriction
- (article-narrow-to-head)
- (while (re-search-forward "^X-Face:" nil t)
- (setq x-faces
- (concat
- (or x-faces "")
- (buffer-substring
- (match-beginning 0)
- (1- (re-search-forward
- "^\\($\\|[^ \t]\\)" nil t))))))))
- (if x-faces
- (let (point start bface eface buffer-read-only)
- (goto-char (point-max))
- (forward-line -1)
- (setq bface (get-text-property (gnus-point-at-bol) 'face)
- eface (get-text-property (1- (gnus-point-at-eol)) 'face))
- (goto-char (point-max))
- (setq point (point))
- (insert x-faces)
- (goto-char point)
- (while (looking-at "\\([^:]+\\): *")
- (put-text-property (match-beginning 1) (1+ (match-end 1))
- 'face bface)
- (setq start (match-end 0))
- (forward-line 1)
- (while (looking-at "[\t ]")
- (forward-line 1))
- (put-text-property start (point)
- 'face eface)))))
- (goto-char (point-min))
- (setq from (message-fetch-field "from"))
- (goto-char (point-min))
- (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:[\t ]*" 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.
+ (let ((wash-face-p buffer-read-only)) ;; When type `W f'
+ (gnus-with-article-headers
+ ;; Delete the old process, if any.
+ (when (process-status "article-x-face")
+ (delete-process "article-x-face"))
+ (if (memq 'xface gnus-article-wash-types)
+ ;; We have already displayed X-Faces, so we remove them
+ ;; instead.
+ (gnus-delete-images 'xface)
+ ;; Display X-Faces.
+ (let (x-faces from face grey)
(save-excursion
- (let ((beg (point))
- (end (1- (re-search-forward "^\\($\\|[^ \t]\\)" nil t)))
- buffer-read-only)
+ (when (and wash-face-p
+ (progn
+ (goto-char (point-min))
+ (not (re-search-forward
+ "^X-Face\\(-[0-9]+\\)?:[\t ]*" nil t)))
+ (gnus-buffer-live-p gnus-original-article-buffer))
+ ;; If type `W f', use gnus-original-article-buffer,
+ ;; otherwise use the current buffer because displaying
+ ;; RFC822 parts calls this function too.
+ (set-buffer gnus-original-article-buffer))
+ (save-restriction
+ (mail-narrow-to-head)
+ (if gnus-treat-display-grey-xface
+ (progn
+ (while (gnus-article-goto-header "X-Face\\(-[0-9]+\\)?")
+ (if (match-beginning 2)
+ (progn
+ (setq grey t)
+ (push (cons (string-to-number (match-string 2))
+ (mail-header-field-value))
+ x-faces))
+ (push (cons 0 (mail-header-field-value)) x-faces)))
+ (dolist (x-face (prog1
+ (nreverse (sort x-faces
+ 'car-less-than-car))
+ (setq x-faces nil)))
+ (push (cdr x-face) x-faces)))
+ (while (gnus-article-goto-header "X-Face")
+ (push (mail-header-field-value) x-faces)))
+ (setq from (message-fetch-field "from"))))
+ (if grey
+ (let ((xpm (gnus-convert-gray-x-face-to-xpm x-faces))
+ image)
+ (when xpm
+ (setq image (gnus-create-image xpm 'xpm t))
+ (gnus-article-goto-header "from")
+ (when (bobp)
+ (insert "From: [no `from' set]\n")
+ (forward-char -17))
+ (gnus-add-wash-type 'xface)
+ (gnus-add-image 'xface image)
+ (gnus-put-image image)))
+ ;; Sending multiple EOFs to xv doesn't work, so we only do a
+ ;; single external face.
+ (when (stringp gnus-article-x-face-command)
+ (setq x-faces (list (car x-faces))))
+ (while (and (setq face (pop x-faces))
+ gnus-article-x-face-command
+ (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)))))
;; We display the face.
(if (symbolp gnus-article-x-face-command)
;; The command is a lisp function, so we call it.
(if (gnus-functionp gnus-article-x-face-command)
- (funcall gnus-article-x-face-command beg end)
+ (funcall gnus-article-x-face-command face)
(error "%s is not a function" gnus-article-x-face-command))
;; The command is a string, so we interpret the command
;; as a, well, command, and fork it off.
(start-process
"article-x-face" nil shell-file-name shell-command-switch
gnus-article-x-face-command))
- (process-send-region "article-x-face" beg end)
+ (with-temp-buffer
+ (insert face)
+ (process-send-region "article-x-face"
+ (point-min) (point-max)))
(process-send-eof "article-x-face"))))))))))
(defun article-decode-mime-words ()
(let ((buffer-read-only nil))
(rfc1843-decode-region (point-min) (point-max)))))
+(defun article-unsplit-urls ()
+ "Remove the newlines that some other mailers insert into URLs."
+ (interactive)
+ (save-excursion
+ (let ((buffer-read-only nil))
+ (goto-char (point-min))
+ (while (re-search-forward
+ "^\\(\\(https?\\|ftp\\)://\\S-+\\)\n\\(\\S-+\\)" nil t)
+ (replace-match "\\1\\3" t)))))
+
(defun article-wash-html (&optional read-charset)
"Format an html article.
If READ-CHARSET, ask for a coding system."
(save-window-excursion
(save-restriction
(narrow-to-region (point) (point-max))
- (mm-setup-w3)
- (let ((w3-strict-width (window-width))
- (url-standalone-mode t))
- (condition-case var
- (w3-region (point-min) (point-max))
- (error))))))))
+ (let* ((func (or gnus-article-wash-function mm-text-html-renderer))
+ (entry (assq func mm-text-html-washer-alist)))
+ (if entry
+ (setq func (cdr entry)))
+ (cond
+ ((gnus-functionp func)
+ (funcall func))
+ (t
+ (apply (car func) (cdr func))))))))))
+
+(defun gnus-article-wash-html-with-w3 ()
+ "Wash the current buffer with w3."
+ (mm-setup-w3)
+ (let ((w3-strict-width (window-width))
+ (url-standalone-mode t)
+ (url-gateway-unplugged t)
+ (w3-honor-stylesheets nil)
+ (w3-delay-image-loads t))
+ (condition-case var
+ (w3-region (point-min) (point-max))
+ (error))))
+
+(defun gnus-article-wash-html-with-w3m ()
+ "Wash the current buffer with emacs-w3m."
+ (mm-setup-w3m)
+ (save-restriction
+ (narrow-to-region (point) (point-max))
+ (let ((w3m-safe-url-regexp (if mm-inline-text-html-with-images
+ nil
+ "\\`cid:"))
+ (w3m-display-inline-images mm-inline-text-html-with-images)
+ w3m-force-redisplay)
+ (w3m-region (point-min) (point-max)))
+ (when mm-inline-text-html-with-w3m-keymap
+ (add-text-properties
+ (point-min) (point-max)
+ (append '(mm-inline-text-html-with-w3m t)
+ (gnus-local-map-property mm-w3m-mode-map))))))
(defun article-hide-list-identifiers ()
"Remove list identifies from the Subject header.
(article-goto-body)
;; Hide the "header".
(when (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\n" nil t)
- (push 'pgp gnus-article-wash-types)
+ (gnus-add-wash-type 'pgp)
(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)
"\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n"
nil t)
(setq end (1+ (match-beginning 0))))
- (push 'pem gnus-article-wash-types)
+ (gnus-add-wash-type 'pem)
(gnus-article-hide-text-type
end
(if (search-forward "\n\n" nil t)
(let ((buffer-read-only nil))
(when (gnus-article-narrow-to-signature)
(gnus-article-hide-text-type
- (point-min) (point-max) 'signature)))))))
+ (point-min) (point-max) 'signature))))))
+ (gnus-set-mode-line 'article))
(defun article-strip-headers-in-body ()
"Strip offensive headers from bodies."
(defun gnus-article-check-hidden-text (type arg)
"Return nil if hiding is necessary.
-Arg can be nil or a number. Nil and positive means hide, negative
+Arg can be nil or a number. nil and positive means hide, negative
means show, 0 means toggle."
(save-excursion
(save-restriction
'article-type type
(point-min) (point-max)
(cons 'article-type (cons type
- gnus-hidden-properties)))))
+ gnus-hidden-properties)))
+ (gnus-delete-wash-type type)))
(defconst article-time-units
`((year . ,(* 365.25 24 60 60))
(interactive (list t))
(article-date-ut 'iso8601 highlight))
-(defun article-show-all ()
- "Show all hidden text in the article buffer."
- (interactive)
- (save-excursion
- (let ((buffer-read-only nil))
- (gnus-article-unhide-text (point-min) (point-max)))))
+;; (defun article-show-all ()
+;; "Show all hidden text in the article buffer."
+;; (interactive)
+;; (save-excursion
+;; (let ((buffer-read-only nil))
+;; (gnus-article-unhide-text (point-min) (point-max)))))
(defun article-remove-leading-whitespace ()
"Remove excessive whitespace from all headers."
(match-beginning invisible) (match-end invisible) props)
(gnus-article-unhide-text-type
(match-beginning visible) (match-end visible) 'emphasis)
- (gnus-put-text-property-excluding-newlines
+ (gnus-put-overlay-excluding-newlines
(match-beginning visible) (match-end visible) 'face face)
- (push 'emphasis gnus-article-wash-types)
+ (gnus-add-wash-type 'emphasis)
(goto-char (match-end invisible)))))))))
(defun gnus-article-setup-highlight-words (&optional highlight-words)
(setq afunc func
gfunc (intern (format "gnus-%s" func))))
(defalias gfunc
- (if (fboundp afunc)
+ (when (fboundp afunc)
`(lambda (&optional interactive &rest args)
,(documentation afunc t)
(interactive (list t))
article-de-base64-unreadable
article-decode-HZ
article-wash-html
+ article-unsplit-urls
article-hide-list-identifiers
article-hide-pgp
article-strip-banner
article-emphasize
article-treat-dumbquotes
article-normalize-headers
- (article-show-all . gnus-article-show-all-headers))))
+;; (article-show-all . gnus-article-show-all-headers)
+ )))
\f
;;;
;;; Gnus article mode
">" end-of-buffer
"\C-c\C-i" gnus-info-find-node
"\C-c\C-b" gnus-bug
+ "R" gnus-article-reply-with-original
+ "F" gnus-article-followup-with-original
"\C-hk" gnus-article-describe-key
"\C-hc" gnus-article-describe-key-briefly
["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t]
["Remove base64" gnus-article-de-base64-unreadable t]
["Treat html" gnus-article-wash-html t]
+ ["Remove newlines from within URLs" gnus-article-unsplit-urls t]
["Decode HZ" gnus-article-decode-HZ t]))
;; Note "Commands" menu is defined in gnus-sum.el for consistency
(make-local-variable 'gnus-article-decoded-p)
(make-local-variable 'gnus-article-mime-handle-alist)
(make-local-variable 'gnus-article-wash-types)
+ (make-local-variable 'gnus-article-image-alist)
(make-local-variable 'gnus-article-charset)
(make-local-variable 'gnus-article-ignored-charsets)
(gnus-set-default-directory)
;; from the head of the article.
(defun gnus-article-set-window-start (&optional line)
(set-window-start
- (get-buffer-window gnus-article-buffer t)
+ (gnus-get-buffer-window gnus-article-buffer t)
(save-excursion
(set-buffer gnus-article-buffer)
(goto-char (point-min))
(unless (eq major-mode 'gnus-article-mode)
(gnus-article-mode))
(setq buffer-read-only nil
- gnus-article-wash-types nil)
+ gnus-article-wash-types nil
+ gnus-article-image-alist nil)
(gnus-run-hooks 'gnus-tmp-internal-hook)
(when gnus-display-mime-function
(funcall gnus-display-mime-function))
;;;
(defvar gnus-mime-button-line-format "%{%([%p. %d%T]%)%}%e\n"
- "The following specs can be used:
+ "Format of the MIME buttons.
+
+Valid specifiers include:
%t The MIME type
%T MIME type, along with additional info
%n The `name' parameter
%d The description, if any
%l The length of the encoded part
%p The part identifier number
-%e Dots if the part isn't displayed")
+%e Dots if the part isn't displayed
+
+General format specifiers can also be used. See
+(gnus)Formatting Variables.")
(defvar gnus-mime-button-line-format-alist
'((?t gnus-tmp-type ?s)
(gnus-mime-inline-part "i" "View As Text, In This Buffer")
(gnus-mime-internalize-part "E" "View Internally")
(gnus-mime-externalize-part "e" "View Externally")
+ (gnus-mime-print-part "p" "Print")
(gnus-mime-pipe-part "|" "Pipe To Command...")
(gnus-mime-action-on-part "." "Take action on the part")))
(gnus-mm-display-part handle))))
(defun gnus-mime-copy-part (&optional handle)
- "Put the the MIME part under point into a new buffer."
+ "Put the MIME part under point into a new buffer."
(interactive)
(gnus-article-check-buffer)
(let* ((handle (or handle (get-text-property (point) 'gnus-data)))
(setq buffer-file-name nil))
(goto-char (point-min)))))
+(defun gnus-mime-print-part (&optional handle filename)
+ "Print the MIME part under point."
+ (interactive (list nil (ps-print-preprint current-prefix-arg)))
+ (gnus-article-check-buffer)
+ (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
+ (contents (and handle (mm-get-part handle)))
+ (file (make-temp-name (expand-file-name "mm." mm-tmp-directory)))
+ (printer (mailcap-mime-info (mm-handle-type handle) "print")))
+ (when contents
+ (if printer
+ (unwind-protect
+ (progn
+ (with-temp-file file
+ (insert contents))
+ (call-process shell-file-name nil
+ (generate-new-buffer " *mm*")
+ nil
+ shell-command-switch
+ (mm-mailcap-command
+ printer file (mm-handle-type handle))))
+ (delete-file file))
+ (with-temp-buffer
+ (insert contents)
+ (gnus-print-buffer))
+ (ps-despool filename)))))
+
(defun gnus-mime-inline-part (&optional handle arg)
"Insert the MIME part under point into the current buffer."
(interactive (list nil current-prefix-arg))
(let ((window (selected-window))
(mail-parse-charset gnus-newsgroup-charset)
(mail-parse-ignored-charsets
- (save-excursion (set-buffer gnus-summary-buffer)
- gnus-newsgroup-ignored-charsets)))
+ (if (gnus-buffer-live-p gnus-summary-buffer)
+ (save-excursion
+ (set-buffer gnus-summary-buffer)
+ gnus-newsgroup-ignored-charsets)
+ nil)))
(save-excursion
(unwind-protect
- (let ((win (get-buffer-window (current-buffer) t))
+ (let ((win (gnus-get-buffer-window (current-buffer) t))
(beg (point)))
(when win
(select-window win))
;; This will remove the part.
(mm-display-part handle)
(save-restriction
- (narrow-to-region (point)
+ (narrow-to-region (point)
(if (eobp) (point) (1+ (point))))
(mm-display-part handle)
;; We narrow to the part itself and
(setq b (point))
(gnus-eval-format
gnus-mime-button-line-format gnus-mime-button-line-format-alist
- `(keymap ,gnus-mime-button-map
- ,@(if (>= (string-to-number emacs-version) 21)
- nil
- (list 'local-map gnus-mime-button-map))
- gnus-callback gnus-mm-display-part
- gnus-part ,gnus-tmp-id
- article-type annotation
- gnus-data ,handle))
+ `(,@(gnus-local-map-property gnus-mime-button-map)
+ gnus-callback gnus-mm-display-part
+ gnus-part ,gnus-tmp-id
+ article-type annotation
+ gnus-data ,handle))
(setq e (point))
(widget-convert-button
'link b e
;; We have to do this since selecting the window
;; may change the point. So we set the window point.
(set-window-point window point)))
- (let* ((handles (or ihandles (mm-dissect-buffer) (mm-uu-dissect)))
+ (let* ((handles (or ihandles (mm-dissect-buffer
+ gnus-article-no-strict-mime)
+ (mm-uu-dissect)))
buffer-read-only handle name type b e display)
(when (and (not ihandles)
(not gnus-displaying-mime))
;;;!!! No, w3 can display everything just fine.
(gnus-mime-display-part (cadr handle)))
((equal (car handle) "multipart/signed")
- (or (memq 'signed gnus-article-wash-types)
- (push 'signed gnus-article-wash-types))
+ (gnus-add-wash-type 'signed)
(gnus-mime-display-security handle))
((equal (car handle) "multipart/encrypted")
- (or (memq 'encrypted gnus-article-wash-types)
- (push 'encrypted gnus-article-wash-types))
+ (gnus-add-wash-type 'encrypted)
(gnus-mime-display-security handle))
;; Other multiparts are handled like multipart/mixed.
(t
',gnus-article-mime-handle-alist))
(gnus-mime-display-alternative
',ihandles ',not-pref ',begend ,id))
- ,@(if (>= (string-to-number emacs-version) 21)
- nil ;; XEmacs doesn't care
- (list 'local-map gnus-mime-button-map))
+ ,@(gnus-local-map-property gnus-mime-button-map)
,gnus-mouse-face-prop ,gnus-article-mouse-face
face ,gnus-article-button-face
- keymap ,gnus-mime-button-map
gnus-part ,id
gnus-data ,handle))
(widget-convert-button 'link from (point)
',gnus-article-mime-handle-alist))
(gnus-mime-display-alternative
',ihandles ',handle ',begend ,id))
- ,@(if (>= (string-to-number emacs-version) 21)
- nil ;; XEmacs doesn't care
- (list 'local-map gnus-mime-button-map))
+ ,@(gnus-local-map-property gnus-mime-button-map)
,gnus-mouse-face-prop ,gnus-article-mouse-face
face ,gnus-article-button-face
- keymap ,gnus-mime-button-map
gnus-part ,id
gnus-data ,handle))
(widget-convert-button 'link from (point)
(goto-char point))))
(defconst gnus-article-wash-status-strings
- (let ((alist '((cite "c" "Possible hidden citation text"
+ (let ((alist '((cite "c" "Possible hidden citation text"
" " "All citation text visible")
(headers "h" "Hidden headers"
" " "All headers visible.")
- (pgp "p" "Encrypted or signed message status hidden"
+ (pgp "p" "Encrypted or signed message status hidden"
" " "No hidden encryption nor digital signature status")
(signature "s" "Signature has been hidden"
" " "Signature is visible")
representing the particular washing function, ON is the string to use
in the article mode line when the washing function is active, and OFF
is the string to use when it is inactive.")
-
-(defun gnus-gnus-article-wash-status-entry (key value)
+
+(defun gnus-article-wash-status-entry (key value)
(let ((entry (assoc key gnus-article-wash-status-strings)))
(if value (nth 1 entry) (nth 2 entry))))
(signature (memq 'signature gnus-article-wash-types))
(overstrike (memq 'overstrike gnus-article-wash-types))
(emphasis (memq 'emphasis gnus-article-wash-types)))
- (concat (gnus-gnus-article-wash-status-entry 'cite cite)
- (gnus-gnus-article-wash-status-entry 'headers
- (or headers boring))
- (gnus-gnus-article-wash-status-entry
- 'pgp (or pgp pem signed encrypted))
- (gnus-gnus-article-wash-status-entry 'signature signature)
- (gnus-gnus-article-wash-status-entry 'overstrike overstrike)
- (gnus-gnus-article-wash-status-entry 'emphasis emphasis)))))
+ (concat
+ (gnus-article-wash-status-entry 'cite cite)
+ (gnus-article-wash-status-entry 'headers (or headers boring))
+ (gnus-article-wash-status-entry 'pgp (or pgp pem signed encrypted))
+ (gnus-article-wash-status-entry 'signature signature)
+ (gnus-article-wash-status-entry 'overstrike overstrike)
+ (gnus-article-wash-status-entry 'emphasis emphasis)))))
+
+(defun gnus-add-wash-type (type)
+ "Add a washing of TYPE to the current status."
+ (add-to-list 'gnus-article-wash-types type))
+
+(defun gnus-delete-wash-type (type)
+ "Add a washing of TYPE to the current status."
+ (setq gnus-article-wash-types (delq type gnus-article-wash-types)))
+
+(defun gnus-add-image (category image)
+ "Add IMAGE of CATEGORY to the list of displayed images."
+ (let ((entry (assq category gnus-article-image-alist)))
+ (unless entry
+ (setq entry (list category))
+ (push entry gnus-article-image-alist))
+ (nconc entry (list image))))
+
+(defun gnus-delete-images (category)
+ "Delete all images in CATEGORY."
+ (let ((entry (assq category gnus-article-image-alist)))
+ (dolist (image (cdr entry))
+ (gnus-remove-image image))
+ (setq gnus-article-image-alist (delq entry gnus-article-image-alist))
+ (gnus-delete-wash-type category)))
(defalias 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers)
(interactive "P")
(gnus-article-check-buffer)
(let ((nosaves
- '("q" "Q" "c" "r" "R" "\C-c\C-f" "m" "a" "f" "F"
+ '("q" "Q" "c" "r" "\C-c\C-f" "m" "a" "f"
"Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"
"=" "^" "\M-^" "|"))
(nosave-but-article
(describe-key-briefly key insert))
(describe-key-briefly key insert)))
+(defun gnus-article-reply-with-original (&optional wide)
+ "Start composing a reply mail to the current message.
+The text in the region will be yanked. If the region isn't active,
+the entire article will be yanked."
+ (interactive "P")
+ (let ((article (cdr gnus-article-current)) cont)
+ (if (not (mark t))
+ (gnus-summary-reply (list (list article)) wide)
+ (setq cont (buffer-substring (point) (mark t)))
+ ;; Deactivate active regions.
+ (when (and (boundp 'transient-mark-mode)
+ transient-mark-mode)
+ (setq mark-active nil))
+ (gnus-summary-reply
+ (list (list article cont)) wide))))
+
+(defun gnus-article-followup-with-original ()
+ "Compose a followup to the current article.
+The text in the region will be yanked. If the region isn't active,
+the entire article will be yanked."
+ (interactive)
+ (let ((article (cdr gnus-article-current))
+ cont)
+ (if (not (mark t))
+ (gnus-summary-followup (list (list article)))
+ (setq cont (buffer-substring (point) (mark t)))
+ ;; Deactivate active regions.
+ (when (and (boundp 'transient-mark-mode)
+ transient-mark-mode)
+ (setq mark-active nil))
+ (gnus-summary-followup
+ (list (list article cont))))))
+
(defun gnus-article-hide (&optional arg force)
"Hide all the gruft in the current article.
This means that PGP stuff, signatures, cited text and (some)
(gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name))
(gnus-request-group gnus-newsgroup-name t)))
+(eval-when-compile
+ (autoload 'nneething-get-file-name "nneething"))
+
(defun gnus-request-article-this-buffer (article group)
"Get an article and insert it into this buffer."
(let (do-update-line sparse-header)
gnus-newsgroup-name)))
(when (and (eq (car method) 'nneething)
(vectorp header))
- (let ((dir (expand-file-name
- (mail-header-subject header)
- (file-name-as-directory
- (or (cadr (assq 'nneething-address method))
- (nth 1 method))))))
- (when (file-directory-p dir)
+ (let ((dir (nneething-get-file-name
+ (mail-header-id header))))
+ (when (and (stringp dir)
+ (file-directory-p dir))
(setq article 'nneething)
(gnus-group-enter-directory dir))))))))
(numberp article)
(gnus-cache-request-article article group))
'article)
+ ;; Check the agent cache.
+ ((and gnus-agent gnus-agent-cache gnus-plugged
+ (numberp article)
+ (gnus-agent-request-article article group))
+ 'article)
;; Get the article and put into the article buffer.
((or (stringp article)
(numberp article))
(set-buffer gnus-summary-buffer)
(gnus-summary-update-article do-update-line sparse-header)
(gnus-summary-goto-subject do-update-line nil t)
- (set-window-point (get-buffer-window (current-buffer) t)
+ (set-window-point (gnus-get-buffer-window (current-buffer) t)
(point))
(set-buffer buf))))))
;; Should we be using derived.el for this?
(unless gnus-article-edit-mode-map
- (setq gnus-article-edit-mode-map (make-sparse-keymap))
+ (setq gnus-article-edit-mode-map (make-keymap))
(set-keymap-parent gnus-article-edit-mode-map text-mode-map)
+
(gnus-define-keys gnus-article-edit-mode-map
+ "\C-c?" describe-mode
"\C-c\C-c" gnus-article-edit-done
- "\C-c\C-k" gnus-article-edit-exit)
+ "\C-c\C-k" gnus-article-edit-exit
+ "\C-c\C-f\C-t" message-goto-to
+ "\C-c\C-f\C-o" message-goto-from
+ "\C-c\C-f\C-b" message-goto-bcc
+ ;;"\C-c\C-f\C-w" message-goto-fcc
+ "\C-c\C-f\C-c" message-goto-cc
+ "\C-c\C-f\C-s" message-goto-subject
+ "\C-c\C-f\C-r" message-goto-reply-to
+ "\C-c\C-f\C-n" message-goto-newsgroups
+ "\C-c\C-f\C-d" message-goto-distribution
+ "\C-c\C-f\C-f" message-goto-followup-to
+ "\C-c\C-f\C-m" message-goto-mail-followup-to
+ "\C-c\C-f\C-k" message-goto-keywords
+ "\C-c\C-f\C-u" message-goto-summary
+ "\C-c\C-f\C-i" message-insert-or-toggle-importance
+ "\C-c\C-f\C-a" message-gen-unsubscribed-mft
+ "\C-c\C-b" message-goto-body
+ "\C-c\C-i" message-goto-signature
+
+ "\C-c\C-t" message-insert-to
+ "\C-c\C-n" message-insert-newsgroups
+ "\C-c\C-o" message-sort-headers
+ "\C-c\C-e" message-elide-region
+ "\C-c\C-v" message-delete-not-region
+ "\C-c\C-z" message-kill-to-signature
+ "\M-\r" message-newline-and-reformat
+ "\C-c\C-a" mml-attach-file
+ "\C-a" message-beginning-of-line
+ "\t" message-tab
+ "\M-;" comment-region)
(gnus-define-keys (gnus-article-edit-wash-map
"\C-c\C-w" gnus-article-edit-mode-map)
"f" gnus-article-edit-full-stops))
+(easy-menu-define
+ gnus-article-edit-mode-field-menu gnus-article-edit-mode-map ""
+ '("Field"
+ ["Fetch To" message-insert-to t]
+ ["Fetch Newsgroups" message-insert-newsgroups t]
+ "----"
+ ["To" message-goto-to t]
+ ["From" message-goto-from t]
+ ["Subject" message-goto-subject t]
+ ["Cc" message-goto-cc t]
+ ["Reply-To" message-goto-reply-to t]
+ ["Summary" message-goto-summary t]
+ ["Keywords" message-goto-keywords t]
+ ["Newsgroups" message-goto-newsgroups t]
+ ["Followup-To" message-goto-followup-to t]
+ ["Mail-Followup-To" message-goto-mail-followup-to t]
+ ["Distribution" message-goto-distribution t]
+ ["Body" message-goto-body t]
+ ["Signature" message-goto-signature t]))
+
(define-derived-mode gnus-article-edit-mode text-mode "Article Edit"
"Major mode for editing articles.
This is an extended text-mode.
(make-local-variable 'gnus-prev-winconf)
(set (make-local-variable 'font-lock-defaults)
'(message-font-lock-keywords t))
+ (set (make-local-variable 'mail-header-separator) "")
+ (easy-menu-add message-mode-field-menu message-mode-map)
+ (mml-mode)
(setq buffer-read-only nil)
(buffer-enable-undo)
(widen))
(interactive "P")
(let ((func gnus-article-edit-done-function)
(buf (current-buffer))
- (start (window-start)))
- ;; We remove all text props from the article buffer.
- (let ((content
- (buffer-substring-no-properties (point-min) (point-max)))
- (p (point)))
- (erase-buffer)
- (insert content)
- (let ((winconf gnus-prev-winconf))
- (gnus-article-mode)
- (set-window-configuration winconf)
- ;; Tippy-toe some to make sure that point remains where it was.
- (save-current-buffer
- (set-buffer buf)
- (set-window-start (get-buffer-window (current-buffer)) start)
- (goto-char p))))
+ (start (window-start))
+ (p (point))
+ (winconf gnus-prev-winconf))
+ (funcall func arg)
+ (set-buffer buf)
+ ;; The cache and backlog have to be flushed somewhat.
+ (when gnus-keep-backlog
+ (gnus-backlog-remove-article
+ (car gnus-article-current) (cdr gnus-article-current)))
+ ;; Flush original article as well.
(save-excursion
- (set-buffer buf)
- (let ((buffer-read-only nil))
- (funcall func arg))
- ;; The cache and backlog have to be flushed somewhat.
- (when gnus-keep-backlog
- (gnus-backlog-remove-article
- (car gnus-article-current) (cdr gnus-article-current)))
- ;; Flush original article as well.
- (save-excursion
- (when (get-buffer gnus-original-article-buffer)
- (set-buffer gnus-original-article-buffer)
- (setq gnus-original-article nil)))
- (when gnus-use-cache
- (gnus-cache-update-article
- (car gnus-article-current) (cdr gnus-article-current))))
+ (when (get-buffer gnus-original-article-buffer)
+ (set-buffer gnus-original-article-buffer)
+ (setq gnus-original-article nil)))
+ (when gnus-use-cache
+ (gnus-cache-update-article
+ (car gnus-article-current) (cdr gnus-article-current)))
+ ;; We remove all text props from the article buffer.
+ (kill-all-local-variables)
+ (gnus-set-text-properties (point-min) (point-max) nil)
+ (gnus-article-mode)
+ (set-window-configuration winconf)
(set-buffer buf)
(set-window-start (get-buffer-window buf) start)
(set-window-point (get-buffer-window buf) (point))))
("\\binfo:\\(//\\)?\\([^'\">\n\t ]+\\)" 0 t
gnus-button-handle-info 2)
;; This is how URLs _should_ be embedded in text...
- ("<URL: *\\([^<>]*\\)>" 0 t gnus-button-embedded-url 1)
+ ("<URL: *\\([^<>]*\\)>" 1 t gnus-button-embedded-url 1)
;; Raw URLs.
(,gnus-button-url-regexp 0 t browse-url 0))
"*Alist of regexps matching buttons in article bodies.
("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t browse-url 0)
("^Subject:" ,gnus-button-url-regexp 0 t browse-url 0)
("^[^:]+:" ,gnus-button-url-regexp 0 t browse-url 0)
+ ("^[^:]+:" "\\bmailto:\\([-a-zA-Z.@_+0-9%=?]+\\)" 0 t gnus-url-mailto 1)
("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t
gnus-button-message-id 3))
"*Alist of headers and regexps to match buttons in article heads.
(inhibit-point-motion-hooks t))
(if (text-property-any end (point-max) 'article-type 'signature)
(progn
- (setq gnus-article-wash-types
- (delq 'signature gnus-article-wash-types))
+ (gnus-delete-wash-type 'signature)
(gnus-remove-text-properties-when
'article-type 'signature end (point-max)
(cons 'article-type (cons 'signature
gnus-hidden-properties))))
- (or (memq 'signature gnus-article-wash-types)
- (push 'signature gnus-article-wash-types))
+ (gnus-add-wash-type 'signature)
(gnus-add-text-properties-when
'article-type nil end (point-max)
(cons 'article-type (cons 'signature
(defun gnus-button-handle-info (url)
"Fetch an info URL."
- (if (string-match
+ (if (string-match
"^\\([^:/]+\\)?/\\(.*\\)"
url)
(gnus-info-find-node
(concat "(" (or (gnus-url-unhex-string (match-string 1 url))
- "Gnus")
- ")"
+ "Gnus")
+ ")"
(gnus-url-unhex-string (match-string 2 url))))
(error "Can't parse %s" url)))
(if (not (string-match "[:/]" address))
;; This is just a simple group url.
(gnus-group-read-ephemeral-group address gnus-select-method)
- (if (not
- (string-match
+ (if (not
+ (string-match
"^\\([^:/]+\\)\\(:\\([^/]+\\)\\)?/\\([^/]+\\)\\(/\\([0-9]+\\)\\)?"
address))
(error "Can't parse %s" address)
(if (not (string-match "=" cur))
nil ; Grace
(setq key (gnus-url-unhex-string (substring cur 0 (match-beginning 0)))
- val (gnus-url-unhex-string (substring cur (match-end 0) nil)))
+ val (gnus-url-unhex-string (substring cur (match-end 0) nil) t))
(if downcase
(setq key (downcase key)))
(setq cur (assoc key retval))
(defvar gnus-next-page-line-format "%{%(Next page...%)%}\n")
(defvar gnus-prev-page-line-format "%{%(Previous page...%)%}\n")
-(defvar gnus-prev-page-map nil)
-(unless gnus-prev-page-map
- (setq gnus-prev-page-map (make-sparse-keymap))
- (define-key gnus-prev-page-map gnus-mouse-2 'gnus-button-prev-page)
- (define-key gnus-prev-page-map "\r" 'gnus-button-prev-page))
+(defvar gnus-prev-page-map
+ (let ((map (make-sparse-keymap)))
+ (unless (>= emacs-major-version 21)
+ ;; XEmacs doesn't care.
+ (set-keymap-parent map gnus-article-mode-map))
+ (define-key map gnus-mouse-2 'gnus-button-prev-page)
+ (define-key map "\r" 'gnus-button-prev-page)
+ map))
(defun gnus-insert-prev-page-button ()
- (let ((buffer-read-only nil))
+ (let ((b (point))
+ (buffer-read-only nil))
(gnus-eval-format
gnus-prev-page-line-format nil
- `(gnus-prev t local-map ,gnus-prev-page-map
- gnus-callback gnus-article-button-prev-page
- article-type annotation))))
-
-(defvar gnus-next-page-map nil)
-(unless gnus-next-page-map
- (setq gnus-next-page-map (make-keymap))
- (suppress-keymap gnus-prev-page-map)
- (define-key gnus-next-page-map gnus-mouse-2 'gnus-button-next-page)
- (define-key gnus-next-page-map "\r" 'gnus-button-next-page))
-
-(defun gnus-button-next-page ()
+ `(,@(gnus-local-map-property gnus-prev-page-map)
+ gnus-prev t
+ gnus-callback gnus-article-button-prev-page
+ article-type annotation))
+ (widget-convert-button
+ 'link b (point)
+ :action 'gnus-button-prev-page
+ :button-keymap gnus-prev-page-map)))
+
+(defvar gnus-prev-page-map
+ (let ((map (make-sparse-keymap)))
+ (unless (>= emacs-major-version 21)
+ ;; XEmacs doesn't care.
+ (set-keymap-parent map gnus-article-mode-map))
+ (define-key map gnus-mouse-2 'gnus-button-prev-page)
+ (define-key map "\r" 'gnus-button-prev-page)
+ map))
+
+(defvar gnus-next-page-map
+ (let ((map (make-sparse-keymap)))
+ (unless (>= emacs-major-version 21)
+ ;; XEmacs doesn't care.
+ (set-keymap-parent map gnus-article-mode-map))
+ (define-key map gnus-mouse-2 'gnus-button-next-page)
+ (define-key map "\r" 'gnus-button-next-page)
+ map))
+
+(defun gnus-button-next-page (&optional args more-args)
"Go to the next page."
(interactive)
(let ((win (selected-window)))
- (select-window (get-buffer-window gnus-article-buffer t))
+ (select-window (gnus-get-buffer-window gnus-article-buffer t))
(gnus-article-next-page)
(select-window win)))
-(defun gnus-button-prev-page ()
+(defun gnus-button-prev-page (&optional args more-args)
"Go to the prev page."
(interactive)
(let ((win (selected-window)))
- (select-window (get-buffer-window gnus-article-buffer t))
+ (select-window (gnus-get-buffer-window gnus-article-buffer t))
(gnus-article-prev-page)
(select-window win)))
(defun gnus-insert-next-page-button ()
- (let ((buffer-read-only nil))
+ (let ((b (point))
+ (buffer-read-only nil))
(gnus-eval-format gnus-next-page-line-format nil
- `(gnus-next
- t local-map ,gnus-next-page-map
- gnus-callback gnus-article-button-next-page
- article-type annotation))))
+ `(,@(gnus-local-map-property gnus-next-page-map)
+ gnus-next t
+ gnus-callback gnus-article-button-next-page
+ article-type annotation))
+ (widget-convert-button
+ 'link b (point)
+ :action 'gnus-button-next-page
+ :button-keymap gnus-next-page-map)))
(defun gnus-article-button-next-page (arg)
"Go to the next page."
(interactive "P")
(let ((win (selected-window)))
- (select-window (get-buffer-window gnus-article-buffer t))
+ (select-window (gnus-get-buffer-window gnus-article-buffer t))
(gnus-article-next-page)
(select-window win)))
"Go to the prev page."
(interactive "P")
(let ((win (selected-window)))
- (select-window (get-buffer-window gnus-article-buffer t))
+ (select-window (gnus-get-buffer-window gnus-article-buffer t))
(gnus-article-prev-page)
(select-window win)))
(gnus-eval-format
gnus-mime-security-button-line-format
gnus-mime-security-button-line-format-alist
- `(keymap ,gnus-mime-security-button-map
- ,@(if (>= (string-to-number emacs-version) 21)
- nil ;; XEmacs doesn't care
- (list 'local-map gnus-mime-security-button-map))
- gnus-callback gnus-mime-security-press-button
- gnus-line-format ,gnus-mime-security-button-line-format
- article-type annotation
- gnus-data ,handle))
+ `(,@(gnus-local-map-property gnus-mime-security-button-map)
+ gnus-callback gnus-mime-security-press-button
+ gnus-line-format ,gnus-mime-security-button-line-format
+ article-type annotation
+ gnus-data ,handle))
(setq e (point))
(widget-convert-button
'link b e