;;; gnus-art.el --- article mode commands for Semi-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 'alist)
(require 'mime-view)
(require 'wid-edit)
"^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-Received:" "^Content-length:" "X-precedence:"
"^X-Authenticated-User:" "^X-Comment" "^X-Report:" "^X-Abuse-Info:"
"^X-HTTP-Proxy:" "^X-Mydeja-Info:" "^X-Copyright" "^X-No-Markup:"
- "^X-Abuse-Info:")
+ "^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-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."
(defcustom gnus-boring-article-headers '(empty followup-to reply-to)
"Headers that are only to be displayed if they have interesting data.
-Possible values in this list are `empty', `newsgroups', `followup-to',
-`to-address', `reply-to', `date', `long-to', and `many-to'."
+Possible values in this list are:
+
+ 'empty Headers with no content.
+ 'newsgroups Newsgroup identical to Gnus group.
+ 'to-address To identical to To-address.
+ 'followup-to Followup-to identical to Newsgroups.
+ 'reply-to Reply-to identical to From.
+ 'date Date less than four days old.
+ 'long-to To and/or Cc longer than 1024 characters.
+ 'many-to Multiple To and/or Cc."
:type '(set (const :tag "Headers with no content." empty)
- (const :tag "Newsgroups with only one group." newsgroups)
- (const :tag "To identical to to-address." to-address)
- (const :tag "Followup-to identical to newsgroups." followup-to)
- (const :tag "Reply-to identical to from." reply-to)
+ (const :tag "Newsgroups identical to Gnus group." newsgroups)
+ (const :tag "To identical to To-address." to-address)
+ (const :tag "Followup-to identical to Newsgroups." followup-to)
+ (const :tag "Reply-to identical to From." reply-to)
(const :tag "Date less than four days old." date)
- (const :tag "Very long To and/or Cc header." long-to)
+ (const :tag "To and/or Cc longer than 1024 characters." long-to)
(const :tag "Multiple To and/or Cc headers." many-to))
:group 'gnus-article-hiding)
;; Fixme: This isn't the right thing for mixed graphical and and
;; non-graphical frames in a session.
-;; gnus-xmas.el overrides this for XEmacs.
(defcustom gnus-article-x-face-command
(cond
+ ((featurep 'xemacs)
+ (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 -"))
((and (fboundp 'image-type-available-p)
(module-installed-p 'x-face-e21))
'x-face-decode-message-header)
- ((and (fboundp 'image-type-available-p)
- (image-type-available-p 'xbm))
- 'gnus-article-display-xface)
- ((and (not (featurep 'xemacs))
- window-system
+ ((gnus-image-type-available-p 'pbm)
+ 'gnus-display-x-face-in-from)
+ ((and window-system
(module-installed-p 'x-face-mule))
'x-face-mule-gnus-article-display-x-face)
- (gnus-article-compface-xbm
- "{ echo '/* Width=48, Height=48 */'; uncompface; } | display -")
(t
"{ 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
- :tag "x-face-decode-message-header (x-face-e21)"
- x-face-decode-message-header)
- (function-item gnus-article-display-xface)
- (function-item x-face-mule-gnus-article-display-x-face)
- function)
+ :type `(choice
+ ,@(let (x-face-e21 x-face-mule)
+ (if (featurep 'xemacs)
+ nil
+ (setq x-face-e21 (module-installed-p 'x-face-e21)
+ x-face-mule (module-installed-p 'x-face-mule)))
+ (delq nil
+ (list
+ 'string
+ (if (or (gnus-image-type-available-p 'xface)
+ (gnus-image-type-available-p 'pbm))
+ '(function-item gnus-display-x-face-in-from))
+ (if (and x-face-e21
+ (fboundp 'image-type-available-p))
+ '(function-item
+ :tag "x-face-decode-message-header (x-face-e21)"
+ x-face-decode-message-header))
+ (if x-face-mule
+ '(function-item
+ x-face-mule-gnus-article-display-x-face))
+ '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) (car (cdr 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:
* gnus-summary-save-in-mail (Unix mail format)
* gnus-summary-save-in-folder (MH folder)
* gnus-summary-save-in-file (article format)
+* gnus-summary-save-body-in-file (article body)
* gnus-summary-save-in-vm (use VM's folder format)
* gnus-summary-write-to-file (article format -- overwrite)."
:group 'gnus-article-saving
(function-item gnus-summary-save-in-mail)
(function-item gnus-summary-save-in-folder)
(function-item gnus-summary-save-in-file)
+ (function-item gnus-summary-save-body-in-file)
(function-item gnus-summary-save-in-vm)
(function-item gnus-summary-write-to-file)))
(background light))
(:foreground "indianred4" :italic t))
(t
- (:italic t))) "Face used for displaying header content."
+ (:italic t)))
+ "Face used for displaying header content."
:group 'gnus-article-headers
:group 'gnus-article-highlight)
:type '(repeat regexp))
(defcustom gnus-unbuttonized-mime-types '(".*/.*")
- "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.
+See also `gnus-buttonized-mime-types' which may override this variable."
+ :version "21.1"
+ :group 'gnus-article-mime
+ :type '(repeat regexp))
+
+(defcustom gnus-buttonized-mime-types nil
+ "List of MIME types that should be given buttons when rendered inline.
+If set, this variable overrides `gnus-unbuttonized-mime-types'.
+To see e.g. security buttons you could set this to
+`(\"multipart/signed\")'."
:version "21.1"
: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-highlight-signature '(or last (typep "text/x-vcard"))
"Highlight 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'."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(put 'gnus-treat-highlight-signature 'highlight t)
(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."
- :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-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))
(eq 'x-face-mule-gnus-article-display-x-face
gnus-article-x-face-command))
'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-article-should-use-smiley-mule
+ (not (or (featurep 'xemacs)
+ (gnus-image-type-available-p 'xpm)
+ (gnus-image-type-available-p 'pbm)))
+ "If non-nil, gnus uses `smiley-mule' for displaying smileys rather than
+`smiley'. It defaults to t when Emacs 20 or earlier is running.
+`smiley-mule' is boundled in BITMAP-MULE package. You can set it to t
+even if you are using Emacs 21+. It has no effect on XEmacs."
+ :group 'gnus-article-various
+ :type 'boolean
+ :get (lambda (symbol)
+ (and (default-value symbol)
+ (not (featurep 'xemacs))
+ (module-installed-p 'smiley-mule)
+ t))
+ :set (lambda (symbol value)
+ (set-default symbol (and value
+ (not (featurep 'xemacs))
+ (module-installed-p 'smiley-mule)
+ t))))
+
+(defvar gnus-article-smiley-mule-loaded-p nil
+ "Internal variable used to say whether `smiley-mule' is loaded (whether
+smiley functions are not overridden by `smiley').")
+
+(defcustom gnus-treat-display-grey-xface
+ (and (not noninteractive)
+ (or (featurep 'xemacs)
+ (and (fboundp 'display-images-p)
+ (display-images-p)))
+ (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))
- (and (fboundp 'image-type-available-p)
- (image-type-available-p 'pbm))
+ (gnus-image-type-available-p 'xpm)
+ (gnus-image-type-available-p 'pbm)
(and (not (featurep 'xemacs))
window-system
(module-installed-p 'smiley-mule)))
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-decode-article-as-default-mime-charset
+ '((gnus-treat-decode-article-as-default-mime-charset
gnus-article-decode-article-as-default-mime-charset)
(gnus-treat-x-pgp-sig gnus-article-verify-x-pgp-sig)
(gnus-treat-strip-banner gnus-article-strip-banner)
(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-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-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-emphasize gnus-article-emphasize)
- (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)
+ ;; Displaying X-Face should be done after unfolding headers
+ ;; to protect bitmap lines.
+ (gnus-treat-display-xface gnus-article-display-x-face)
+ (gnus-treat-fold-newsgroups gnus-article-treat-fold-newsgroups)
(gnus-treat-buttonize-head gnus-article-add-buttons-to-head)
- (gnus-treat-display-smileys ,(if (or (featurep 'xemacs)
- (>= emacs-major-version 21))
- 'gnus-smiley-display
- 'gnus-article-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)
(gnus-article-show-hidden-text 'boring-headers)
(when (eq 1 (point-min))
(set-window-start (get-buffer-window (current-buffer)) 1)))
- (unless gnus-inhibit-hiding
- (save-excursion
- (save-restriction
- (let ((buffer-read-only nil)
- (inhibit-read-only t)
- (case-fold-search t)
- (max (1+ (length gnus-sorted-header-list)))
- (ignored (when (not gnus-visible-headers)
- (cond ((stringp gnus-ignored-headers)
- gnus-ignored-headers)
- ((listp gnus-ignored-headers)
- (mapconcat 'identity gnus-ignored-headers
- "\\|")))))
- (visible
- (cond ((stringp gnus-visible-headers)
- gnus-visible-headers)
- ((and gnus-visible-headers
- (listp gnus-visible-headers))
- (mapconcat 'identity gnus-visible-headers "\\|"))))
- (inhibit-point-motion-hooks t)
- beg)
- ;; First we narrow to just the headers.
- (article-narrow-to-head)
- ;; Hide any "From " lines at the beginning of (mail) articles.
- (while (looking-at "From ")
- (forward-line 1))
- (unless (bobp)
- (if delete
- (delete-region (point-min) (point))
- (gnus-article-hide-text (point-min) (point)
- (nconc (list 'article-type 'headers)
- gnus-hidden-properties))))
- ;; Then treat the rest of the header lines.
- ;; Then we use the two regular expressions
- ;; `gnus-ignored-headers' and `gnus-visible-headers' to
- ;; select which header lines is to remain visible in the
- ;; article buffer.
- (while (re-search-forward "^[^ \t]*:" nil t)
- (beginning-of-line)
- ;; Mark the rank of the header.
- (put-text-property
- (point) (1+ (point)) 'message-rank
- (if (or (and visible (looking-at visible))
- (and ignored
- (not (looking-at ignored))))
- (gnus-article-header-rank)
- (+ 2 max)))
- (forward-line 1))
- (message-sort-headers-1)
- (when (setq beg (text-property-any
- (point-min) (point-max) 'message-rank (+ 2 max)))
- ;; We delete or make invisible the unwanted headers.
- (push 'headers gnus-article-wash-types)
- (if delete
- (progn
- (add-text-properties
- (point-min) (+ 5 (point-min))
- '(article-type headers dummy-invisible t))
- (delete-region beg (point-max)))
- (gnus-article-hide-text-type beg (point-max) 'headers))))))))
- )
+ (unless gnus-inhibit-hiding
+ (save-excursion
+ (save-restriction
+ (let ((inhibit-read-only t)
+ (case-fold-search t)
+ (max (1+ (length gnus-sorted-header-list)))
+ (ignored (when (not gnus-visible-headers)
+ (cond ((stringp gnus-ignored-headers)
+ gnus-ignored-headers)
+ ((listp gnus-ignored-headers)
+ (mapconcat 'identity gnus-ignored-headers
+ "\\|")))))
+ (visible
+ (cond ((stringp gnus-visible-headers)
+ gnus-visible-headers)
+ ((and gnus-visible-headers
+ (listp gnus-visible-headers))
+ (mapconcat 'identity gnus-visible-headers "\\|"))))
+ (inhibit-point-motion-hooks t)
+ beg)
+ ;; First we narrow to just the headers.
+ (article-narrow-to-head)
+ ;; Hide any "From " lines at the beginning of (mail) articles.
+ (while (looking-at "From ")
+ (forward-line 1))
+ (unless (bobp)
+ (if delete
+ (delete-region (point-min) (point))
+ (gnus-article-hide-text (point-min) (point)
+ (nconc (list 'article-type 'headers)
+ gnus-hidden-properties))))
+ ;; Then treat the rest of the header lines.
+ ;; Then we use the two regular expressions
+ ;; `gnus-ignored-headers' and `gnus-visible-headers' to
+ ;; select which header lines is to remain visible in the
+ ;; article buffer.
+ (while (re-search-forward "^[^ \t:]*:" nil t)
+ (beginning-of-line)
+ ;; Mark the rank of the header.
+ (put-text-property
+ (point) (1+ (point)) 'message-rank
+ (if (or (and visible (looking-at visible))
+ (and ignored
+ (not (looking-at ignored))))
+ (gnus-article-header-rank)
+ (+ 2 max)))
+ (forward-line 1))
+ (message-sort-headers-1)
+ (when (setq beg (text-property-any
+ (point-min) (point-max) 'message-rank (+ 2 max)))
+ ;; We delete or make invisible the unwanted headers.
+ (gnus-add-wash-type 'headers)
+ (if delete
+ (progn
+ (add-text-properties
+ (point-min) (+ 5 (point-min))
+ '(article-type headers dummy-invisible t))
+ (delete-region beg (point-max)))
+ (gnus-article-hide-text-type beg (point-max) 'headers)))))))))
(defun article-hide-boring-headers (&optional arg)
"Toggle hiding of headers that aren't very interesting.
(header-end (point-min))
header-start field-end field-start
(inhibit-point-motion-hooks t)
- (inhibit-read-only t)
- buffer-read-only)
+ (inhibit-read-only t))
(save-restriction
(widen)
(while (and (setq header-start
'invisible t)))
;; If the invisible text is not terminated with newline, we
;; won't expose it. Because it may be created by x-face-mule.
- ;; BTW, XEmacs sometimes fail in putting a invisible text
+ ;; BTW, XEmacs sometimes fail in putting an invisible text
;; property with `gnus-article-hide-text' (really?). In that
;; case, the invisible text might be started from the middle of
- ;; a line so we will expose the sort of thing.
+ ;; a line, so we will expose the sort of thing.
(when (or (not (or (eq header-start field-start)
(eq ?\n (char-before field-start))))
- (eq ?\n (char-before field-end)))
+ (eq ?\n (char-before field-end))
+ ;; Expose a boundary line anyway.
+ (string-equal
+ "\nX-Boundary: "
+ (buffer-substring (max (- field-end 13) header-start)
+ field-end)))
(remove-text-properties field-start field-end
gnus-hidden-properties)
(put-text-property field-start field-end
(put-text-property
(point) end '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)
+ (unless (featurep 'xemacs)
+ (when (and (>= emacs-major-version 21)
+ (not gnus-article-should-use-smiley-mule)
+ gnus-article-smiley-mule-loaded-p)
+ (load "smiley" nil t)
+ (setq gnus-article-smiley-mule-loaded-p nil))
+ (when (and gnus-article-should-use-smiley-mule
+ (not gnus-article-smiley-mule-loaded-p))
+ (load "smiley-mule" nil t)
+ (setq gnus-article-smiley-mule-loaded-p t)))
+ (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)
(width (window-width (get-buffer-window (current-buffer)))))
(save-restriction
(article-goto-body)
- (let ((adaptive-fill-mode nil))
+ (let ((adaptive-fill-mode nil)) ;Why? -sm
(while (not (eobp))
(end-of-line)
(when (>= (current-column) (min fill-column width))
(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))))
+ (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
+ (if grey
+ (sort x-faces 'car-less-than-car)
+ (nreverse x-faces))
+ (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 ()
(error))
gnus-newsgroup-ignored-charsets))
ct cte ctl charset format)
- (save-excursion
- (save-restriction
- (article-narrow-to-head)
- (setq ct (message-fetch-field "Content-Type" t)
- cte (message-fetch-field "Content-Transfer-Encoding" t)
- ctl (and ct (ignore-errors
- (mail-header-parse-content-type ct)))
- charset (cond
- (prompt
- (mm-read-coding-system "Charset to decode: "))
- (ctl
- (mail-content-type-get ctl 'charset)))
- format (and ctl (mail-content-type-get ctl 'format)))
- (when cte
- (setq cte (mail-header-strip cte)))
- (if (and ctl (not (string-match "/" (car ctl))))
- (setq ctl nil))
- (goto-char (point-max)))
- (forward-line 1)
- (save-restriction
- (narrow-to-region (point) (point-max))
- (when (and (eq mail-parse-charset 'gnus-decoded)
- (eq (mm-body-7-or-8) '8bit))
- ;; The text code could have been decoded.
- (setq charset mail-parse-charset))
- (when (and (or (not ctl)
- (equal (car ctl) "text/plain"))
- (not format)) ;; article with format will decode later.
- (mm-decode-body
- charset (and cte (intern (downcase
- (gnus-strip-whitespace cte))))
- (car ctl)))))))
+ (save-excursion
+ (save-restriction
+ (article-narrow-to-head)
+ (setq ct (message-fetch-field "Content-Type" t)
+ cte (message-fetch-field "Content-Transfer-Encoding" t)
+ ctl (and ct (ignore-errors
+ (mail-header-parse-content-type ct)))
+ charset (cond
+ (prompt
+ (mm-read-coding-system "Charset to decode: "))
+ (ctl
+ (mail-content-type-get ctl 'charset)))
+ format (and ctl (mail-content-type-get ctl 'format)))
+ (when cte
+ (setq cte (mail-header-strip cte)))
+ (if (and ctl (not (string-match "/" (car ctl))))
+ (setq ctl nil))
+ (goto-char (point-max)))
+ (forward-line 1)
+ (save-restriction
+ (narrow-to-region (point) (point-max))
+ (when (and (eq mail-parse-charset 'gnus-decoded)
+ (eq (mm-body-7-or-8) '8bit))
+ ;; The text code could have been decoded.
+ (setq charset mail-parse-charset))
+ (when (and (or (not ctl)
+ (equal (car ctl) "text/plain"))
+ (not format)) ;; article with format will decode later.
+ (mm-decode-body
+ charset (and cte (intern (downcase
+ (gnus-strip-whitespace cte))))
+ (car ctl)))))))
(defun article-decode-encoded-words ()
"Remove encoded-word encoding from headers."
(let ((charset (save-excursion
(set-buffer gnus-summary-buffer)
default-mime-charset)))
- (mime-decode-header-in-buffer charset)
- )))
+ (mime-decode-header-in-buffer charset))))
-(defun article-de-quoted-unreadable (&optional force)
+(defun article-decode-group-name ()
+ "Decode group names in `Newsgroups:'."
+ (let ((inhibit-point-motion-hooks t)
+ buffer-read-only
+ (method (gnus-find-method-for-group gnus-newsgroup-name)))
+ (when (and (or gnus-group-name-charset-method-alist
+ gnus-group-name-charset-group-alist)
+ (gnus-buffer-live-p gnus-original-article-buffer))
+ (when (nnmail-fetch-field "Newsgroups")
+ (nnheader-replace-header "Newsgroups"
+ (gnus-decode-newsgroups
+ (with-current-buffer
+ gnus-original-article-buffer
+ (nnmail-fetch-field "Newsgroups"))
+ gnus-newsgroup-name method)))
+ (when (nnmail-fetch-field "Followup-To")
+ (nnheader-replace-header "Followup-To"
+ (gnus-decode-newsgroups
+ (with-current-buffer
+ gnus-original-article-buffer
+ (nnmail-fetch-field "Followup-To"))
+ gnus-newsgroup-name method))))))
+
+(defun article-de-quoted-unreadable (&optional force read-charset)
"Translate a quoted-printable-encoded article.
If FORCE, decode the article whether it is marked as quoted-printable
-or not."
- (interactive (list 'force))
+or not.
+If READ-CHARSET, ask for a coding system."
+ (interactive (list 'force current-prefix-arg))
(save-excursion
(let ((buffer-read-only nil) type charset)
(if (gnus-buffer-live-p gnus-original-article-buffer)
(mail-content-type-get ctl 'charset)))
(if (stringp charset)
(setq charset (intern (downcase charset)))))))
+ (if read-charset
+ (setq charset (mm-read-coding-system "Charset: " charset)))
(unless charset
(setq charset gnus-newsgroup-charset))
(when (or force
(quoted-printable-decode-region
(point) (point-max) (mm-charset-to-coding-system charset))))))
-(defun article-de-base64-unreadable (&optional force)
+(defun article-de-base64-unreadable (&optional force read-charset)
"Translate a base64 article.
-If FORCE, decode the article whether it is marked as base64 not."
- (interactive (list 'force))
+If FORCE, decode the article whether it is marked as base64 not.
+If READ-CHARSET, ask for a coding system."
+ (interactive (list 'force current-prefix-arg))
(save-excursion
(let ((buffer-read-only nil) type charset)
(if (gnus-buffer-live-p gnus-original-article-buffer)
(mail-content-type-get ctl 'charset)))
(if (stringp charset)
(setq charset (intern (downcase charset)))))))
+ (if read-charset
+ (setq charset (mm-read-coding-system "Charset: " charset)))
(unless charset
(setq charset gnus-newsgroup-charset))
(when (or force
(let ((buffer-read-only nil))
(rfc1843-decode-region (point-min) (point-max)))))
-(defun article-wash-html ()
- "Format an html article."
+(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."
+ (interactive "P")
+ (save-excursion
(let ((buffer-read-only nil)
charset)
(if (gnus-buffer-live-p gnus-original-article-buffer)
(mail-content-type-get ctl 'charset)))
(if (stringp charset)
(setq charset (intern (downcase charset)))))))
+ (if read-charset
+ (setq charset (mm-read-coding-system "Charset: " charset)))
(unless charset
(setq charset gnus-newsgroup-charset))
(article-goto-body)
(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)
(start (point))
(end (point-max))
(orig (buffer-substring start end))
- (trans (babel-as-string orig)))
+ (trans (babel-as-string orig)))
(save-restriction
(narrow-to-region start end)
(delete-region start end)
- (insert trans))))))
+ (insert trans))))))
(defun article-hide-signature (&optional arg)
"Hide the signature in the current article.
(1+ button)
(next-single-property-change (1+ button) 'mime-view-entity
nil (point-max))
- 'signature))))))))
+ 'signature)))))))
+ (gnus-set-mode-line 'article))
(defun article-strip-headers-in-body ()
"Strip offensive headers from bodies."
(looking-at "[ \t]*$"))
(gnus-delete-line))))))
-(defun article-replace-with-quoted-text ()
- "Replace the entire article with the quoted text in the article."
- (interactive)
- (unless gnus-cite-prefix-alist
- (error "No quoted text in the article"))
- (gnus-summary-show-article t)
- (save-excursion
- (set-buffer gnus-article-buffer)
- (gnus-cite-parse-maybe t)
- (let ((prefix (concat "^" (caar gnus-cite-prefix-alist)))
- (buffer-read-only nil)
- (body nil))
- (dolist (line (sort (copy-sequence (cdar gnus-cite-prefix-alist)) '<))
- (save-excursion
- (set-buffer gnus-original-article-buffer)
- (goto-char (point-min))
- (forward-line (1- line))
- (push (buffer-substring (point) (progn (forward-line 1) (point)))
- body)))
- (article-goto-body)
- (forward-line -1)
- (delete-region (point) (point-max))
- (mapcar #'insert (mapcar #'string-as-unibyte (nreverse body)))
- (goto-char (point-min))
- (while (re-search-forward prefix nil t)
- (replace-match "" t t))
- (gnus-article-prepare-display))))
-
(defun article-narrow-to-head ()
"Narrow the buffer to the head of the message.
Point is left at the beginning of the narrowed-to region."
(replace-match "" nil t)))
;; Then replace multiple empty lines with a single empty line.
(article-goto-body)
- (while (re-search-forward "\n\n\n+" nil t)
+ (while (re-search-forward "\n\n\\(\n+\\)" nil t)
(unless (gnus-annotation-in-region-p
(match-beginning 0) (match-end 0))
- (replace-match "\n\n" t t))))))
+ (delete-region (match-beginning 1) (match-end 1)))))))
(defun article-strip-leading-space ()
"Remove all white space from the beginning of the lines in the article."
(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))
(re-search-forward "^X-Sent:[ \t]" nil t))
(setq bface (get-text-property (gnus-point-at-bol) 'face)
date (or (get-text-property (gnus-point-at-bol)
- 'original-date)
- date)
+ 'original-date)
+ date)
eface (get-text-property (1- (gnus-point-at-eol))
'face)))
(let ((buffer-read-only nil))
(format "%02d" (nth 2 dtime))
":"
(format "%02d" (nth 1 dtime)))))))
- (error
- (format "Date: %s (from Oort)" date))))
+ (error
+ (format "Date: %s (from Oort)" date))))
(defun article-date-local (&optional highlight)
"Convert the current article date to the local timezone."
(interactive (list t))
(article-date-ut 'iso8601 highlight))
-(defun article-show-all ()
- "Show all hidden text in the article buffer."
- (interactive)
- (save-excursion
- (widen)
- (let ((buffer-read-only nil))
- (gnus-article-unhide-text (point-min) (point-max))
- (gnus-remove-text-with-property 'gnus-prev)
- (gnus-remove-text-with-property 'gnus-next))))
+;; (defun article-show-all ()
+;; "Show all hidden text in the article buffer."
+;; (interactive)
+;; (save-excursion
+;; (widen)
+;; (let ((buffer-read-only nil))
+;; (gnus-article-unhide-text (point-min) (point-max))
+;; (gnus-remove-text-with-property 'gnus-prev)
+;; (gnus-remove-text-with-property 'gnus-next))))
(defun article-show-all-headers ()
"Show all hidden headers in the article buffer."
visible (nth 2 elem)
face (nth 3 elem))
(while (re-search-forward regexp nil t)
- (when (and (match-beginning visible) (match-beginning invisible))
- (push 'emphasis gnus-article-wash-types)
- (gnus-article-hide-text
- (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
- (match-beginning visible) (match-end visible) 'face face)
- (goto-char (match-end invisible)))))))))
+ (when (and (match-beginning visible) (match-beginning invisible))
+ (gnus-article-hide-text
+ (match-beginning invisible) (match-end invisible) props)
+ (gnus-article-unhide-text-type
+ (match-beginning visible) (match-end visible) 'emphasis)
+ (gnus-put-overlay-excluding-newlines
+ (match-beginning visible) (match-end visible) 'face face)
+ (gnus-add-wash-type 'emphasis)
+ (goto-char (match-end invisible)))))))))
(defun gnus-article-setup-highlight-words (&optional highlight-words)
"Setup newsgroup emphasis alist."
(car (push result file-name-history)))))))
;; Create the directory.
(gnus-make-directory (file-name-directory file))
- ;; If we have read a directory, we append the default file name.
+ ;; If we have read a directory, we append the default file name.
(when (file-directory-p file)
(setq file (expand-file-name (file-name-nondirectory
default-name)
filename)
(defun gnus-summary-write-to-file (&optional filename)
- "Write this article to a file.
+ "Write this article to a file, overwriting it if the file exists.
Optional argument FILENAME specifies file name.
The directory to save in defaults to `gnus-article-save-directory'."
(gnus-summary-save-in-file nil t))
(when (string-equal command "")
(if gnus-last-shell-command
(setq command gnus-last-shell-command)
- (error "A command is required.")))
+ (error "A command is required")))
(gnus-eval-in-buffer-window gnus-article-buffer
(save-restriction
(widen)
(shell-command-on-region (point-min) (point-max) command nil)))
(setq gnus-last-shell-command command))
+(defun gnus-summary-pipe-to-muttprint (&optional command)
+ "Pipe this article to muttprint."
+ (setq command (read-string
+ "Print using command: " gnus-summary-muttprint-program
+ nil gnus-summary-muttprint-program))
+ (gnus-summary-save-in-pipe command))
+
;;; Article file names when saving.
(defun gnus-capitalize-newsgroup (newsgroup)
(expand-file-name
(if (gnus-use-long-file-name 'not-save)
newsgroup
- (expand-file-name "news" (gnus-newsgroup-directory-form newsgroup)))
+ (file-relative-name
+ (expand-file-name "news" (gnus-newsgroup-directory-form newsgroup))
+ default-directory))
gnus-article-save-directory)))
(defun gnus-sender-save-name (newsgroup headers &optional last-file)
(put-text-property (match-end 0) (point-max)
'face eface)))))))))
+(defun article-verify-cancel-lock ()
+ "Verify Cancel-Lock header."
+ (interactive)
+ (if (gnus-buffer-live-p gnus-original-article-buffer)
+ (canlock-verify gnus-original-article-buffer)))
+
(eval-and-compile
(mapcar
(lambda (func)
(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))
(apply ',afunc args))))))))
'(article-hide-headers
article-verify-x-pgp-sig
+ article-verify-cancel-lock
article-hide-boring-headers
article-toggle-headers
article-treat-overstrike
article-de-base64-unreadable
article-decode-HZ
article-wash-html
+ article-unsplit-urls
article-hide-list-identifiers
article-hide-pgp
article-strip-banner
article-strip-trailing-space
article-strip-blank-lines
article-strip-all-blank-lines
- article-replace-with-quoted-text
article-date-local
article-date-english
article-date-iso8601
article-treat-dumbquotes
article-normalize-headers
(article-show-all-headers . gnus-article-show-all-headers)
- (article-show-all . gnus-article-show-all))))
+;; (article-show-all . gnus-article-show-all)
+ )))
\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
["Treat overstrike" gnus-article-treat-overstrike t]
["Remove carriage return" gnus-article-remove-cr t]
["Remove leading whitespace" gnus-article-remove-leading-whitespace 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)
;; Init original article buffer.
(save-excursion
(set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
- (set-buffer-multibyte nil)
+ (set-buffer-multibyte t)
(setq major-mode 'gnus-original-article-mode)
(make-local-variable 'gnus-original-article))
(if (get-buffer name)
;; 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))
result)
(save-excursion
(gnus-article-setup-buffer)
- (set-buffer gnus-original-article-buffer)
+ (set-buffer gnus-article-buffer)
;; Deactivate active regions.
(when (and (boundp 'transient-mark-mode)
transient-mark-mode)
;;;###autoload
(defun gnus-article-prepare-display ()
"Make the current buffer look like a nice article."
- (setq gnus-article-wash-types nil)
- (gnus-run-hooks 'gnus-tmp-internal-hook)
+ (let ((gnus-article-buffer (current-buffer))
+ buffer-read-only)
+ (unless (eq major-mode 'gnus-article-mode)
+ (gnus-article-mode))
+ (setq buffer-read-only nil
+ gnus-button-marker-list nil
+ gnus-article-wash-types nil
+ gnus-article-image-alist nil)
+ (save-restriction
+ (widen)
+ (static-if (featurep 'xemacs)
+ (map-extents (lambda (extent maparg) (delete-extent extent)))
+ (let ((lists (overlay-lists)))
+ (dolist (overlay (nconc (car lists) (cdr lists)))
+ (delete-overlay overlay)))))
+ (gnus-run-hooks 'gnus-tmp-internal-hook))
+ (set-buffer gnus-original-article-buffer)
;; Display message.
(setq mime-message-structure gnus-current-headers)
(mime-buffer-entity-set-buffer-internal mime-message-structure
(let (mime-display-header-hook mime-display-text/plain-hook)
(funcall gnus-article-display-method-for-mime))
(funcall gnus-article-display-method-for-traditional))
- ;; Associate this article with the current summary buffer.
- (setq gnus-article-current-summary gnus-summary-buffer)
;; Call the treatment functions.
- (let ((inhibit-read-only t)
- buffer-read-only)
+ (let ((inhibit-read-only t))
(save-restriction
(widen)
(if gnus-show-mime
;;;
(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")))
(goto-char (point-min))
(or (search-forward "\n\n") (goto-char (point-max)))
(let (buffer-read-only)
- (delete-region (point) (point-max)))
- (mm-display-parts handles)))))
+ (delete-region (point) (point-max))
+ (mm-display-parts handles))))))
(defun gnus-mime-save-part-and-strip ()
"Save the MIME part under point then replace it with an external body."
(interactive)
(gnus-article-check-buffer)
(let* ((data (get-text-property (point) 'gnus-data))
- file param)
+ file param
+ (handles gnus-article-mime-handles))
(if (mm-multiple-handles gnus-article-mime-handles)
- (error "This function is not implemented."))
+ (error "This function is not implemented"))
(setq file (and data (mm-save-part data)))
(when file
(with-current-buffer (mm-handle-buffer data)
(set-buffer gnus-summary-buffer)
(gnus-article-edit-article
`(lambda ()
- (erase-buffer)
- (let ((mail-parse-charset (or gnus-article-charset
- ',gnus-newsgroup-charset))
- (mail-parse-ignored-charsets
- (or gnus-article-ignored-charsets
- ',gnus-newsgroup-ignored-charsets))
- (mbl mml-buffer-list))
- (setq mml-buffer-list nil)
- (insert-buffer gnus-original-article-buffer)
- (mime-to-mml gnus-article-mime-handles)
- (setq gnus-article-mime-handles nil)
- (make-local-hook 'kill-buffer-hook)
- (let ((mbl1 mml-buffer-list))
- (setq mml-buffer-list mbl)
- (set (make-local-variable 'mml-buffer-list) mbl1))
- (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t)))
+ (erase-buffer)
+ (let ((mail-parse-charset (or gnus-article-charset
+ ',gnus-newsgroup-charset))
+ (mail-parse-ignored-charsets
+ (or gnus-article-ignored-charsets
+ ',gnus-newsgroup-ignored-charsets))
+ (mbl mml-buffer-list))
+ (setq mml-buffer-list nil)
+ (insert-buffer gnus-original-article-buffer)
+ (mime-to-mml ',handles)
+ (setq gnus-article-mime-handles nil)
+ (let ((mbl1 mml-buffer-list))
+ (setq mml-buffer-list mbl)
+ (set (make-local-variable 'mml-buffer-list) mbl1))
+ ;; LOCAL argument of add-hook differs between GNU Emacs
+ ;; and XEmacs. make-local-hook makes sure they are local.
+ (make-local-hook 'kill-buffer-hook)
+ (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t)))
`(lambda (no-highlight)
(let ((mail-parse-charset (or gnus-article-charset
',gnus-newsgroup-charset))
(mail-parse-ignored-charsets
(or gnus-article-ignored-charsets
',gnus-newsgroup-ignored-charsets)))
- (mml-to-mime)
- (mml-destroy-buffers)
- (remove-hook 'kill-buffer-hook
- 'mml-destroy-buffers t)
- (kill-local-variable 'mml-buffer-list))
+ (mml-to-mime)
+ (mml-destroy-buffers)
+ (remove-hook 'kill-buffer-hook
+ 'mml-destroy-buffers t)
+ (kill-local-variable 'mml-buffer-list))
(gnus-summary-edit-article-done
,(or (mail-header-references gnus-current-headers) "")
,(gnus-group-read-only-p)
(mm-handle-undisplayer handle)
(mm-handle-disposition handle)
(mm-handle-description handle)
- (mm-handle-cache handle)
+ nil
(mm-handle-id handle)))
(setq gnus-article-mime-handles
(mm-merge-handles gnus-article-mime-handles handle))
(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))
(setq charset
(or (cdr (assq arg
gnus-summary-show-article-charset-alist))
- (read-coding-system "Charset: ")))))
+ (mm-read-coding-system "Charset: ")))))
(forward-line 2)
(mm-insert-inline handle
(if (and charset
(goto-char b)))))
(defun gnus-mime-view-part-as-charset (&optional handle arg)
- "Insert the MIME part under point into the current buffer."
+ "Insert the MIME part under point into the current buffer using the
+specified charset."
(interactive (list nil current-prefix-arg))
(gnus-article-check-buffer)
(let* ((handle (or handle (get-text-property (point) 'gnus-data)))
(let ((gnus-newsgroup-charset
(or (cdr (assq arg
gnus-summary-show-article-charset-alist))
- (read-coding-system "Charset: ")))
- (gnus-newsgroup-ignored-charsets 'gnus-all))
+ (mm-read-coding-system "Charset: ")))
+ (gnus-newsgroup-ignored-charsets 'gnus-all))
(gnus-article-press-button)))))
(defun gnus-mime-externalize-part (&optional handle)
(defun gnus-mime-internalize-part (&optional handle)
"View the MIME part under point with an internal viewer.
-In no internal viewer is available, use an external viewer."
+If no internal viewer is available, use an external viewer."
(interactive)
(gnus-article-check-buffer)
(let* ((handle (or handle (get-text-property (point) 'gnus-data)))
(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) (1+ (point)))
+ (narrow-to-region (point)
+ (if (eobp) (point) (1+ (point))))
(mm-display-part handle)
;; We narrow to the part itself and
;; then call the treatment functions.
nil id
(gnus-article-mime-total-parts)
(mm-handle-media-type handle)))))
- (select-window window))))
+ (if (window-live-p window)
+ (select-window window)))))
(goto-char point)
(delete-region (gnus-point-at-bol) (progn (forward-line 1) (point)))
(gnus-insert-mime-button
(defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed)
(let ((gnus-tmp-name
- (or (mail-content-type-get (mm-handle-type handle)
- 'name)
- (mail-content-type-get (mm-handle-disposition handle)
- 'filename)
- (mail-content-type-get (mm-handle-type handle)
- 'url)
+ (or (mail-content-type-get (mm-handle-type handle) 'name)
+ (mail-content-type-get (mm-handle-disposition handle) 'filename)
+ (mail-content-type-get (mm-handle-type handle) 'url)
""))
(gnus-tmp-type (mm-handle-media-type handle))
(gnus-tmp-description
(setq gnus-tmp-type-long (concat gnus-tmp-type
(and (not (equal gnus-tmp-name ""))
(concat "; " gnus-tmp-name))))
- (or (equal gnus-tmp-description "")
- (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long)))
+ (unless (equal gnus-tmp-description "")
+ (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long)))
(unless (bolp)
(insert "\n"))
(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
"inline")
(mm-attachment-override-p handle))))
(mm-automatic-display-p handle)
- (or (mm-inlined-p handle)
+ (or (and
+ (mm-inlinable-p handle)
+ (mm-inlined-p handle))
(mm-automatic-external-display-p type)))
(setq display t)
(when (equal (mm-handle-media-supertype handle) "text")
(defun gnus-unbuttonized-mime-type-p (type)
"Say whether TYPE is to be unbuttonized."
(unless gnus-inhibit-mime-unbuttonizing
- (catch 'found
- (let ((types gnus-unbuttonized-mime-types))
- (while types
- (when (string-match (pop types) type)
- (throw 'found t)))))))
+ (when (catch 'found
+ (let ((types gnus-unbuttonized-mime-types))
+ (while types
+ (when (string-match (pop types) type)
+ (throw 'found t)))))
+ (not (catch 'found
+ (let ((types gnus-buttonized-mime-types))
+ (while types
+ (when (string-match (pop types) type)
+ (throw 'found t)))))))))
(defun gnus-article-insert-newline ()
"Insert a newline, but mark it as undeletable."
',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)
(when ibegend
(goto-char point))))
+(defconst gnus-article-wash-status-strings
+ (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"
+ " " "No hidden encryption nor digital signature status")
+ (signature "s" "Signature has been hidden"
+ " " "Signature is visible")
+ (overstrike "o" "Overstrike (^H) characters applied"
+ " " "No overstrike characters applied")
+ (gnus-show-mime "m" "Mime processing is activated"
+ " " "Mime processing is not activated")
+ (emphasis "e" "/*_Emphasis_*/ characters applied"
+ " " "No /*_emphasis_*/ characters applied")))
+ result)
+ (dolist (entry alist result)
+ (let ((key (nth 0 entry))
+ (on (copy-sequence (nth 1 entry)))
+ (on-help (nth 2 entry))
+ (off (copy-sequence (nth 3 entry)))
+ (off-help (nth 4 entry)))
+ (put-text-property 0 1 'help-echo on-help on)
+ (put-text-property 0 1 'help-echo off-help off)
+ (push (list key on off) result))))
+ "Alist of strings describing wash status in the mode line.
+Each entry has the form (KEY ON OF), where the KEY is a symbol
+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-article-wash-status-entry (key value)
+ (let ((entry (assoc key gnus-article-wash-status-strings)))
+ (if value (nth 1 entry) (nth 2 entry))))
+
(defun gnus-article-wash-status ()
"Return a string which display status of article washing."
(save-excursion
(signature (memq 'signature gnus-article-wash-types))
(overstrike (memq 'overstrike gnus-article-wash-types))
(emphasis (memq 'emphasis gnus-article-wash-types)))
- (format "%c%c%c%c%c%c%c"
- (if cite ?c ? )
- (if (or headers boring) ?h ? )
- (if (or pgp pem signed encrypted) ?p ? )
- (if signature ?s ? )
- (if overstrike ?o ? )
- (if gnus-show-mime ?m ? )
- (if emphasis ?e ? )))))
+ (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 'gnus-show-mime gnus-show-mime)
+ (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)
;; save it to file.
(goto-char (point-max))
(insert "\n")
- (write-region-as-binary (point-min) (point-max) file-name 'append)
+ (let ((file-name-coding-system nnmail-pathname-coding-system)
+ (pathname-coding-system nnmail-pathname-coding-system))
+ (write-region-as-binary (point-min) (point-max) file-name 'append))
t)))
(defun gnus-narrow-to-page (&optional arg)
(interactive "P")
(gnus-article-check-buffer)
(let ((nosaves
- '("q" "Q" "c" "r" "R" "\C-c\C-f" "m" "a" "f" "F"
- "Zc" "ZC" "ZE" "ZJ" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"
- "=" "^" "\M-^" "|"))
- (nosave-but-article
- '("A\r"))
- (nosave-in-article
- '("\C-d"))
- (up-to-top
- '("n" "Gn" "p" "Gp"))
- keys new-sum-point)
+ '("q" "Q" "c" "r" "\C-c\C-f" "m" "a" "f"
+ "Zc" "ZC" "ZE" "ZJ" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"
+ "=" "^" "\M-^" "|"))
+ (nosave-but-article
+ '("A\r"))
+ (nosave-in-article
+ '("\C-d"))
+ (up-to-top
+ '("n" "Gn" "p" "Gp"))
+ keys new-sum-point)
(save-excursion
(set-buffer gnus-article-current-summary)
(let (gnus-pick-mode)
- (push (or key last-command-event) unread-command-events)
+ (push (or key last-command-event) unread-command-events)
(setq keys (static-if (featurep 'xemacs)
(events-to-keys (read-key-sequence nil))
(read-key-sequence nil)))))
(message "")
(if (or (member keys nosaves)
- (member keys nosave-but-article)
- (member keys nosave-in-article))
- (let (func)
- (save-window-excursion
- (pop-to-buffer gnus-article-current-summary 'norecord)
- ;; We disable the pick minor mode commands.
- (let (gnus-pick-mode)
- (setq func (lookup-key (current-local-map) keys))))
- (if (or (not func)
+ (member keys nosave-but-article)
+ (member keys nosave-in-article))
+ (let (func)
+ (save-window-excursion
+ (pop-to-buffer gnus-article-current-summary 'norecord)
+ ;; We disable the pick minor mode commands.
+ (let (gnus-pick-mode)
+ (setq func (lookup-key (current-local-map) keys))))
+ (if (or (not func)
(numberp func))
- (ding)
- (unless (member keys nosave-in-article)
- (set-buffer gnus-article-current-summary))
- (call-interactively func)
- (setq new-sum-point (point)))
- (when (member keys nosave-but-article)
- (pop-to-buffer gnus-article-buffer 'norecord)))
+ (ding)
+ (unless (member keys nosave-in-article)
+ (set-buffer gnus-article-current-summary))
+ (call-interactively func)
+ (setq new-sum-point (point)))
+ (when (member keys nosave-but-article)
+ (pop-to-buffer gnus-article-buffer 'norecord)))
;; These commands should restore window configuration.
(let ((obuf (current-buffer))
- (owin (current-window-configuration))
- (opoint (point))
- (summary gnus-article-current-summary)
- func in-buffer selected)
- (if not-restore-window
- (pop-to-buffer summary 'norecord)
- (switch-to-buffer summary 'norecord))
- (setq in-buffer (current-buffer))
- ;; We disable the pick minor mode commands.
- (if (and (setq func (let (gnus-pick-mode)
+ (owin (current-window-configuration))
+ (opoint (point))
+ (summary gnus-article-current-summary)
+ func in-buffer selected)
+ (if not-restore-window
+ (pop-to-buffer summary 'norecord)
+ (switch-to-buffer summary 'norecord))
+ (setq in-buffer (current-buffer))
+ ;; We disable the pick minor mode commands.
+ (if (and (setq func (let (gnus-pick-mode)
(lookup-key (current-local-map) keys)))
(functionp func))
- (progn
- (call-interactively func)
- (setq new-sum-point (point))
+ (progn
+ (call-interactively func)
+ (setq new-sum-point (point))
(when (eq in-buffer (current-buffer))
(setq selected (gnus-summary-select-article))
(set-buffer obuf)
(when win
(set-window-point win new-sum-point)))) )
(switch-to-buffer gnus-article-buffer)
- (ding))))))
+ (ding))))))
(defun gnus-article-describe-key (key)
"Display documentation of the function invoked by KEY. KEY is a string."
(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."
+ "Get an article and insert it into this buffer.
+T-gnus change: Insert an article into `gnus-original-article-buffer'."
(let (do-update-line sparse-header)
+ ;; The current buffer is `gnus-article-buffer'.
(prog1
(save-excursion
(erase-buffer)
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))))))))
+ (setq gnus-original-article (cons group article))
+
+ ;; The current buffer is `gnus-original-article-buffer'.
+ (if (get-buffer gnus-original-article-buffer)
+ (set-buffer gnus-original-article-buffer)
+ (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
+ (set-buffer-multibyte nil)
+ (buffer-disable-undo)
+ (setq major-mode 'gnus-original-article-mode)
+ (setq buffer-read-only nil))
(cond
;; Refuse to select canceled articles.
(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))
(setq gnus-override-method (pop methods)))
(while (not result)
(when (eq gnus-override-method 'current)
- (setq gnus-override-method gnus-current-select-method))
+ (setq gnus-override-method
+ (with-current-buffer gnus-summary-buffer
+ gnus-current-select-method)))
(erase-buffer)
(gnus-kill-all-overlays)
(let ((gnus-newsgroup-name group))
;; Associate this article with the current summary buffer.
(setq gnus-article-current-summary gnus-summary-buffer)
- ;; Take the article from the original article buffer
- ;; and place it in the buffer it's supposed to be in.
- (when (and (get-buffer gnus-article-buffer)
- (equal (buffer-name (current-buffer))
- (buffer-name (get-buffer gnus-article-buffer))))
- (save-excursion
- (if (get-buffer gnus-original-article-buffer)
- (set-buffer gnus-original-article-buffer)
- (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
- (set-buffer-multibyte nil)
- (buffer-disable-undo)
- (setq major-mode 'gnus-original-article-mode)
- (setq buffer-read-only t))
- (let (buffer-read-only)
- (erase-buffer)
- (insert-buffer-substring gnus-article-buffer))
- (setq gnus-original-article (cons group article)))
+ ;; Copy the requested article from `gnus-original-article-buffer'.
+ (unless (equal (buffer-name (current-buffer))
+ (buffer-name (get-buffer gnus-original-article-buffer)))
+ (insert-buffer gnus-original-article-buffer))
- ;; Decode charsets.
- (run-hooks 'gnus-article-decode-hook)
- ;; Mark article as decoded or not.
- (setq gnus-article-decoded-p gnus-article-decode-hook))
+ ;; Decode charsets.
+ (run-hooks 'gnus-article-decode-hook)
+ ;; Mark article as decoded or not.
+ (setq gnus-article-decoded-p gnus-article-decode-hook)
;; Update sparse articles.
(when (and do-update-line
(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))
-(defun gnus-article-edit-mode ()
+(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.
\\{gnus-article-edit-mode-map}"
- (interactive)
- (setq major-mode 'gnus-article-edit-mode)
- (setq mode-name "Article Edit")
- (use-local-map gnus-article-edit-mode-map)
(make-local-variable 'gnus-article-edit-done-function)
(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)
- (gnus-run-hooks 'text-mode-hook 'gnus-article-edit-mode-hook))
+ (widen))
(defun gnus-article-edit (&optional force)
"Edit the current article.
(interactive "P")
(let ((func gnus-article-edit-done-function)
(buf (current-buffer))
- (start (window-start)))
+ (start (window-start))
+ (p (point))
+ (winconf gnus-prev-winconf))
(remove-hook 'gnus-article-mode-hook
'gnus-article-mime-edit-article-unwind)
- ;; 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))))
+ (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))))
nil t)
(replace-match "")))
(apply ,gnus-article-edit-done-function args)
- (set-buffer (get-buffer-create gnus-original-article-buffer))
- (erase-buffer)
- (insert-buffer gnus-article-buffer)
+ (insert
+ (prog1
+ (buffer-substring-no-properties (point-min) (point-max))
+ (set-buffer (get-buffer-create gnus-original-article-buffer))
+ (erase-buffer)))
(setq gnus-current-headers (gnus-article-make-full-mail-header))
+ (set-buffer gnus-article-buffer)
(gnus-article-prepare-display)))
(substitute-key-definition 'gnus-article-edit-done
'gnus-article-mime-edit-done
(set-buffer (get-buffer-create gnus-original-article-buffer))
(erase-buffer)))
(setq gnus-current-headers (gnus-article-make-full-mail-header))
+ (set-buffer gnus-article-buffer)
(gnus-article-prepare-display)
(set-window-configuration winconf))))
;;; Internal Variables:
-(defcustom gnus-button-url-regexp "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\)\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?\\([-a-zA-Z0-9_=!?#$@~`%&*+|\\/:;.,]\\|\\w\\)+\\([-a-zA-Z0-9_=#$@~`%&*+|\\/]\\|\\w\\)\\)"
+(defcustom gnus-button-url-regexp "\\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\\)\\)"
"Regular expression that matches URLs."
:group 'gnus-article-buttons
:type 'regexp)
(defcustom gnus-button-alist
- `(("<\\(url:[>\n\t ]*?\\)?news:[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>"
- 0 t gnus-button-message-id 2)
- ("\\bnews:\\([^>\n\t ]*@[^>)!;:,\n\t ]*\\)" 0 t gnus-button-message-id 1)
+ `(("<\\(url:[>\n\t ]*?\\)?\\(nntp\\|news\\):[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>"
+ 0 t gnus-button-handle-news 3)
+ ("\\b\\(nntp\\|news\\):\\([^>\n\t ]*@[^>)!;:,\n\t ]*\\)" 0 t
+ gnus-button-handle-news 2)
("\\(\\b<\\(url:[>\n\t ]*\\)?news:[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)"
1 t
gnus-button-fetch-group 4)
("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>" 0 t gnus-url-mailto 2)
("mailto:\\([-a-zA-Z.@_+0-9%=?]+\\)" 0 t gnus-url-mailto 1)
("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1)
+ ;; This is info
+ ("\\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.
(integer :tag "Regexp group")))))
(defcustom gnus-header-button-alist
- `(("^\\(References\\|Message-I[Dd]\\):" "<[^>]+>"
+ `(("^\\(References\\|Message-I[Dd]\\):" "<[^<>]+>"
0 t gnus-button-message-id 0)
("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 t gnus-button-reply 1)
("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+"
("^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.
(interactive "e")
(set-buffer (window-buffer (posn-window (event-start event))))
(let* ((pos (posn-point (event-start event)))
- (data (get-text-property pos 'gnus-data))
+ (data (get-text-property pos 'gnus-data))
(fun (get-text-property pos 'gnus-callback)))
(goto-char pos)
(when fun
(limit (next-single-property-change end 'mime-view-entity
nil (point-max))))
(if (text-property-any end limit 'article-type 'signature)
- (gnus-remove-text-properties-when
- 'article-type 'signature end limit
- (cons 'article-type (cons 'signature
- gnus-hidden-properties)))
+ (progn
+ (gnus-delete-wash-type 'signature)
+ (gnus-remove-text-properties-when
+ 'article-type 'signature end limit
+ (cons 'article-type (cons 'signature
+ gnus-hidden-properties))))
+ (gnus-add-wash-type 'signature)
(gnus-add-text-properties-when
'article-type nil end limit
(cons 'article-type (cons 'signature
- gnus-hidden-properties)))))))
+ gnus-hidden-properties)))))
+ (let ((gnus-article-mime-handle-alist-1 gnus-article-mime-handle-alist))
+ (gnus-set-mode-line 'article))))
(defun gnus-button-entry ()
;; Return the first entry in `gnus-button-alist' matching this place.
(gnus-message 1 "You must define `%S' to use this button"
(cons fun args)))))))
+(defun gnus-parse-news-url (url)
+ (let (scheme server group message-id articles)
+ (with-temp-buffer
+ (insert url)
+ (goto-char (point-min))
+ (when (looking-at "\\([A-Za-z]+\\):")
+ (setq scheme (match-string 1))
+ (goto-char (match-end 0)))
+ (when (looking-at "//\\([^/]+\\)/")
+ (setq server (match-string 1))
+ (goto-char (match-end 0)))
+
+ (cond
+ ((looking-at "\\(.*@.*\\)")
+ (setq message-id (match-string 1)))
+ ((looking-at "\\([^/]+\\)/\\([-0-9]+\\)")
+ (setq group (match-string 1)
+ articles (split-string (match-string 2) "-")))
+ ((looking-at "\\([^/]+\\)/?")
+ (setq group (match-string 1)))
+ (t
+ (error "Unknown news URL syntax"))))
+ (list scheme server group message-id articles)))
+
+(defun gnus-button-handle-news (url)
+ "Fetch a news URL."
+ (destructuring-bind (scheme server group message-id articles)
+ (gnus-parse-news-url url)
+ (cond
+ (message-id
+ (save-excursion
+ (set-buffer gnus-summary-buffer)
+ (if server
+ (let ((gnus-refer-article-method (list (list 'nntp server))))
+ (gnus-summary-refer-article message-id))
+ (gnus-summary-refer-article message-id))))
+ (group
+ (gnus-button-fetch-group url)))))
+
+(defun gnus-button-handle-info (url)
+ "Fetch an info URL."
+ (if (string-match
+ "^\\([^:/]+\\)?/\\(.*\\)"
+ url)
+ (gnus-info-find-node
+ (concat "(" (or (gnus-url-unhex-string (match-string 1 url))
+ "Gnus")
+ ")"
+ (gnus-url-unhex-string (match-string 2 url))))
+ (error "Can't parse %s" url)))
+
(defun gnus-button-message-id (message-id)
"Fetch MESSAGE-ID."
(save-excursion
(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 "^\\([^:/]+\\)\\(:\\([^/]+\\)/\\)?\\(.*\\)$"
- address))
+ (if (not
+ (string-match
+ "^\\([^:/]+\\)\\(:\\([^/]+\\)\\)?/\\([^/]+\\)\\(/\\([0-9]+\\)\\)?"
+ address))
(error "Can't parse %s" address)
(gnus-group-read-ephemeral-group
(match-string 4 address)
(nntp-address ,(match-string 1 address))
(nntp-port-number ,(if (match-end 3)
(match-string 3 address)
- "nntp")))))))
+ "nntp")))
+ nil nil nil
+ (and (match-end 6) (list (string-to-int (match-string 6 address))))))))
(defun gnus-url-parse-query-string (query &optional downcase)
(let (retval pairs cur key val)
(setq pairs (split-string query "&"))
(while pairs
(setq cur (car pairs)
- pairs (cdr pairs))
+ pairs (cdr pairs))
(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)))
- (if downcase
- (setq key (downcase key)))
- (setq cur (assoc key retval))
- (if cur
- (setcdr cur (cons val (cdr cur)))
- (setq retval (cons (list key val) retval)))))
+ 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) t))
+ (if downcase
+ (setq key (downcase key)))
+ (setq cur (assoc key retval))
+ (if cur
+ (setcdr cur (cons val (cdr cur)))
+ (setq retval (cons (list key val) retval)))))
retval))
-(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))
-
(defun gnus-url-mailto (url)
;; Send mail to someone
(when (string-match "mailto:/*\\(.*\\)" url)
(setq url (substring url (match-beginning 1) nil)))
(let (to args subject func)
(if (string-match (regexp-quote "?") url)
- (setq to (gnus-url-unhex-string (substring url 0 (match-beginning 0)))
- args (gnus-url-parse-query-string
- (substring url (match-end 0) nil) t))
+ (setq to (gnus-url-unhex-string (substring url 0 (match-beginning 0)))
+ args (gnus-url-parse-query-string
+ (substring url (match-end 0) nil) t))
(setq to (gnus-url-unhex-string url)))
(setq args (cons (list "to" to) args)
- subject (cdr-safe (assoc "subject" args)))
+ subject (cdr-safe (assoc "subject" args)))
(gnus-msg-mail)
(while args
(setq func (intern-soft (concat "message-goto-" (downcase (caar args)))))
(if (fboundp func)
- (funcall func)
- (message-position-on-field (caar args)))
+ (funcall func)
+ (message-position-on-field (caar args)))
(insert (mapconcat 'identity (cdar args) ", "))
(setq args (cdr args)))
(if subject
- (message-goto-body)
+ (message-goto-body)
(message-goto-subject))))
(defun gnus-button-embedded-url (address)
"Activate ADDRESS with `browse-url'."
(browse-url (gnus-strip-whitespace address)))
-(eval-when-compile
- ;; Silence the byte-compiler.
- (autoload 'smiley-toggle-buffer "gnus-bitmap"))
-(defun gnus-article-smiley-display ()
- "Display \"smileys\" as small graphical icons."
- (smiley-toggle-buffer 1 (current-buffer) (point-min) (point-max)))
-
;;; Next/prev buttons in the article buffer.
(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))
-(static-if (featurep 'xemacs)
- (defun gnus-insert-prev-page-button ()
- (let ((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))))
- (defun gnus-insert-prev-page-button ()
- (let ((buffer-read-only nil)
- (situation (get-text-property (point-min) 'mime-view-situation)))
- (set-keymap-parent gnus-prev-page-map (current-local-map))
- (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
- mime-view-situation ,situation))))
- )
+(defun gnus-insert-prev-page-button ()
+ (let ((b (point))
+ (buffer-read-only nil)
+ (situation (get-text-property (point-min) 'mime-view-situation)))
+ (gnus-eval-format
+ gnus-prev-page-line-format nil
+ `(,@(gnus-local-map-property gnus-prev-page-map)
+ gnus-prev t
+ gnus-callback gnus-article-button-prev-page
+ article-type annotation
+ mime-view-situation ,situation))
+ (widget-convert-button
+ 'link b (point)
+ :action 'gnus-button-prev-page
+ :button-keymap gnus-prev-page-map)))
-(defvar gnus-next-page-map nil)
-(unless gnus-next-page-map
- (setq gnus-next-page-map (make-sparse-keymap))
- (define-key gnus-next-page-map gnus-mouse-2 'gnus-button-next-page)
- (define-key gnus-next-page-map "\r" 'gnus-button-next-page))
+(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 ()
+(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)))
-(static-if (featurep 'xemacs)
- (defun gnus-insert-next-page-button ()
- (let ((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))))
- (defun gnus-insert-next-page-button ()
- (let ((buffer-read-only nil)
- (situation (get-text-property (point-min) 'mime-view-situation)))
- (set-keymap-parent gnus-next-page-map (current-local-map))
- (gnus-eval-format gnus-next-page-line-format nil
- `(gnus-next
- t local-map ,gnus-next-page-map
+(defun gnus-insert-next-page-button ()
+ (let ((b (point))
+ (buffer-read-only nil)
+ (situation (get-text-property (point-min) 'mime-view-situation)))
+ (gnus-eval-format gnus-next-page-line-format nil
+ `(,@(gnus-local-map-property gnus-next-page-map)
+ gnus-next t
gnus-callback gnus-article-button-next-page
article-type annotation
- mime-view-situation ,situation))))
- )
+ mime-view-situation ,situation))
+ (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)))
This variable is a list of FUNCTION or (REGEXP . FUNCTION). If item
is FUNCTION, FUNCTION will be apply to all newsgroups. If item is a
-(REGEXP . FUNCTION), FUNCTION will be only apply to thes newsgroups
+\(REGEXP . FUNCTION), FUNCTION will be only apply to thes newsgroups
whose names match REGEXP.
For example:
-((\"chinese\" . gnus-decode-encoded-word-region-by-guess)
+\((\"chinese\" . gnus-decode-encoded-word-region-by-guess)
mail-decode-encoded-word-region
(\"chinese\" . rfc1843-decode-region))
")
(string-match (car x) gnus-newsgroup-name))
(nconc gnus-decode-header-methods-cache
(list (cdr x))))))
- gnus-decode-header-methods))
+ gnus-decode-header-methods))
(let ((xlist gnus-decode-header-methods-cache))
(pop xlist)
(save-restriction
(unless func
(error (format "Can't find the encrypt protocol %s" protocol)))
(if (equal gnus-newsgroup-name "nndraft:drafts")
- (error "Can't encrypt the article in group nndraft:drafts."))
+ (error "Can't encrypt the article in group nndraft:drafts"))
(if (equal gnus-newsgroup-name "nndraft:queue")
- (error "Don't encrypt the article in group nndraft:queue."))
+ (error "Don't encrypt the article in group nndraft:queue"))
(gnus-summary-iterate n
(save-excursion
(set-buffer gnus-summary-buffer)
(error "The current newsgroup does not support article encrypt"))
(gnus-summary-show-article t)
(setq references
- (or (mail-header-references gnus-current-headers) ""))
+ (or (mail-header-references gnus-current-headers) ""))
(set-buffer gnus-article-buffer)
(let* ((buffer-read-only nil)
(headers
(defun gnus-mime-security-verify-or-decrypt (handle)
(mm-remove-parts (cdr handle))
(let ((region (mm-handle-multipart-ctl-parameter handle 'gnus-region))
- buffer-read-only)
+ point buffer-read-only)
+ (if region
+ (goto-char (car region)))
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (with-current-buffer (mm-handle-multipart-original-buffer handle)
+ (let* ((mm-verify-option 'known)
+ (mm-decrypt-option 'known)
+ (nparts (mm-possibly-verify-or-decrypt (cdr handle) handle)))
+ (unless (eq nparts (cdr handle))
+ (mm-destroy-parts (cdr handle))
+ (setcdr handle nparts))))
+ (setq point (point))
+ (gnus-mime-display-security handle)
+ (goto-char (point-max)))
(when region
- (delete-region (car region) (cdr region))
+ (delete-region (point) (cdr region))
(set-marker (car region) nil)
- (set-marker (cdr region) nil)))
- (with-current-buffer (mm-handle-multipart-original-buffer handle)
- (let* ((mm-verify-option 'known)
- (mm-decrypt-option 'known)
- (nparts (mm-possibly-verify-or-decrypt (cdr handle) handle)))
- (unless (eq nparts (cdr handle))
- (mm-destroy-parts (cdr handle))
- (setcdr handle nparts))))
- (let ((point (point))
- buffer-read-only)
- (gnus-mime-display-security handle)
+ (set-marker (cdr region) nil))
(goto-char point)))
(defun gnus-mime-security-show-details (handle)
(let ((gnus-mime-security-button-pressed t)
(gnus-mime-security-button-line-format
(get-text-property (point) 'gnus-line-format))
- buffer-read-only)
+ buffer-read-only)
(forward-char -1)
(while (eq (get-text-property (point) 'gnus-line-format)
gnus-mime-security-button-line-format)
(forward-char -1))
(forward-char)
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (gnus-insert-mime-security-button handle))
(delete-region (point)
(or (text-property-not-all
(point) (point-max)
- 'gnus-line-format
- gnus-mime-security-button-line-format)
- (point-max)))
- (gnus-insert-mime-security-button handle))
+ 'gnus-line-format
+ gnus-mime-security-button-line-format)
+ (point-max))))
(if (gnus-buffer-live-p gnus-mime-security-details-buffer)
(with-current-buffer gnus-mime-security-details-buffer
(erase-buffer)
(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
(defun gnus-mime-display-security (handle)
(save-restriction
(narrow-to-region (point) (point))
- (gnus-insert-mime-security-button handle)
+ (unless (gnus-unbuttonized-mime-type-p (car handle))
+ (gnus-insert-mime-security-button handle))
(gnus-mime-display-mixed (cdr handle))
(unless (bolp)
(insert "\n"))
- (let ((gnus-mime-security-button-line-format
- gnus-mime-security-button-end-line-format))
- (gnus-insert-mime-security-button handle))
+ (unless (gnus-unbuttonized-mime-type-p (car handle))
+ (let ((gnus-mime-security-button-line-format
+ gnus-mime-security-button-end-line-format))
+ (gnus-insert-mime-security-button handle)))
(mm-set-handle-multipart-parameter
handle 'gnus-region
(cons (set-marker (make-marker) (point-min))
(defun gnus-article-header-presentation-method (entity situation)
(mime-insert-header entity)
- )
+ (article-decode-group-name))
(set-alist 'mime-header-presentation-method-alist
'gnus-original-article-mode