-;;; gnus-art.el --- article mode commands for Gnus
-;; Copyright (C) 1996,97,98,99 Free Software Foundation, Inc.
+;;; gnus-art.el --- article mode commands for Semi-gnus
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
-;; Keywords: news
+;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; Katsumi Yamaoka <yamaoka@jpl.org>
+;; Keywords: mail, news, MIME
;; This file is part of GNU Emacs.
;;; Code:
(eval-when-compile (require 'cl))
+(eval-when-compile (require 'static))
-(require 'custom)
+(require 'path-util)
(require 'gnus)
(require 'gnus-sum)
(require 'gnus-spec)
(require 'gnus-int)
-(require 'browse-url)
-(require 'mm-bodies)
-(require 'mail-parse)
-(require 'mm-decode)
-(require 'mm-view)
+(require 'alist)
+(require 'mime-view)
(require 'wid-edit)
-(require 'mm-uu)
+
+;; Avoid byte-compile warnings.
+(eval-when-compile
+ (require 'mm-bodies)
+ (require 'mail-parse)
+ (require 'mm-decode)
+ (require 'mm-view)
+ (require 'mm-uu)
+ )
(defgroup gnus-article nil
"Article display."
"^Originator:" "^X-Problems-To:" "^X-Auth-User:" "^X-Post-Time:"
"^X-Admin:" "^X-UID:" "^Resent-[-A-Za-z]+:" "^X-Mailing-List:"
"^Precedence:" "^Original-[-A-Za-z]+:" "^X-filename:" "^X-Orcpt:"
- "^Old-Received:" "^X-Pgp-Fingerprint:" "^X-Pgp-Key-Id:"
- "^X-Pgp-Public-Key-Url:" "^X-Auth:" "^X-From-Line:"
+ "^Old-Received:" "^X-Pgp" "^X-Auth:" "^X-From-Line:"
"^X-Gnus-Article-Number:" "^X-Majordomo:" "^X-Url:" "^X-Sender:"
- "^X-Mailing-List:" "^MBOX-Line" "^Priority:" "^X-Pgp" "^X400-[-A-Za-z]+:"
- "^Status:" "^X-Gnus-Mail-Source:" "^Cancel-Lock:")
+ "^MBOX-Line" "^Priority:" "^X-Pgp" "^X400-[-A-Za-z]+:"
+ "^Status:" "^X-Gnus-Mail-Source:" "^Cancel-Lock:"
+ "^X-FTN" "^X-EXP32-SerialNo:" "^Encoding:" "^Importance:"
+ "^Autoforwarded:" "^Original-Encoded-Information-Types:" "^X-Ya-Pop3:"
+ "^X-Face-Version:" "^X-Vms-To:" "^X-ML-NAME:" "^X-ML-COUNT:"
+ "^Mailing-List:" "^X-finfo:" "^X-md5sum:" "^X-md5sum-Origin:"
+ "^X-Sun-Charset:" "^X-Accept-Language:" "^X-Envelope-Sender:"
+ "^List-[A-Za-z]+:" "^X-Listprocessor-Version:"
+ "^X-Received:" "^X-Distribute:" "^X-Sequence:" "^X-Juno-Line-Breaks:"
+ "^X-Notes-Item:" "^X-MS-TNEF-Correlator:" "^x-uunet-gateway:"
+ "^X-Received:" "^Content-length:" "X-precedence:")
"*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."
(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 header." long-to)
- (const :tag "Multiple To headers." many-to))
+ (const :tag "Very long To and/or Cc header." long-to)
+ (const :tag "Multiple To and/or Cc headers." many-to))
:group 'gnus-article-hiding)
(defcustom gnus-signature-separator '("^-- $" "^-- *$")
:group 'gnus-article-signature)
(defcustom gnus-signature-limit nil
- "Provide a limit to what is considered a signature.
+ "Provide a limit to what is considered a signature.
If it is a number, no signature may not be longer (in characters) than
that number. If it is a floating point number, no signature may be
longer (in lines) than that number. If it is a function, the function
:group 'gnus-article-hiding)
(defcustom gnus-article-x-face-command
- "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | display -"
+ (cond
+ ;; 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.
+ ((and (fboundp 'image-type-available-p)
+ (image-type-available-p 'xbm))
+ 'gnus-article-display-xface)
+ ((and (not (featurep 'xemacs))
+ window-system
+ (module-installed-p 'x-face-mule))
+ 'x-face-mule-gnus-article-display-x-face)
+ (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 'string ;Leave function case to Lisp.
+ :type '(choice string
+ (function-item gnus-article-display-xface)
+ (function-item x-face-mule-gnus-article-display-x-face)
+ function)
:group 'gnus-article-washing)
(defcustom gnus-article-x-face-too-ugly nil
:type '(choice regexp (const nil))
:group 'gnus-article-washing)
+(defcustom gnus-article-banner-alist nil
+ "Banner alist for stripping.
+For example,
+ ((egroups . \"^[ \\t\\n]*-------------------+\\\\( eGroups Sponsor -+\\\\)?....\\n\\\\(.+\\n\\\\)+\"))"
+ :type '(repeat (cons symbol regexp))
+ :group 'gnus-article-washing)
+
(defcustom gnus-emphasis-alist
(let ((format
- "\\(\\s-\\|^\\|[-\"]\\|\\s(\\|\\s)\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\s-\\|[-?!.,;:\"]\\|\\s(\\|\\s)\\)")
+ "\\(\\s-\\|^\\|[-\"]\\|\\s(\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\s-\\|[-,;:\"]\\s-\\|[?!.]+\\s-\\|\\s)\\)")
(types
'(("_" "_" underline)
("/" "/" italic)
,@(mapcar
(lambda (spec)
(list
- (format format (car spec) (cadr spec))
+ (format format (car spec) (car (cdr spec)))
2 3 (intern (format "gnus-emphasis-%s" (nth 2 spec)))))
types)))
"*Alist that says how to fontify certain phrases.
face))
:group 'gnus-article-emphasis)
+(defcustom gnus-emphasize-whitespace-regexp "^[ \t]+\\|[ \t]*\n"
+ "A regexp to describe whitespace which should not be emphasized.
+Typical values are \"^[ \\t]+\\\\|[ \\t]*\\n\" and \"[ \\t]+\\\\|[ \\t]*\\n\".
+The former avoids underlining of leading and trailing whitespace,
+and the latter avoids underlining any whitespace at all."
+ :group 'gnus-article-emphasis
+ :type 'regexp)
+
(defface gnus-emphasis-bold '((t (:bold t)))
"Face used for displaying strong emphasized text (*word*)."
:group 'gnus-article-emphasis)
:group 'gnus-article-emphasis)
(defface gnus-emphasis-underline-italic '((t (:italic t :underline t)))
- "Face used for displaying underlined italic emphasized text (_*word*_)."
+ "Face used for displaying underlined italic emphasized text (_/word/_)."
:group 'gnus-article-emphasis)
(defface gnus-emphasis-bold-italic '((t (:bold t :italic t)))
(cons :value ("" "") regexp (repeat string))
(sexp :value nil))))
+(defcustom gnus-article-display-method-for-mime
+ 'gnus-article-display-mime-message
+ "Function to display a MIME message.
+The function is called from the article buffer."
+ :group 'gnus-article-mime
+ :type 'function)
+
+(defcustom gnus-article-display-method-for-traditional
+ 'gnus-article-display-traditional-message
+ "*Function to display a traditional message.
+The function is called from the article buffer."
+ :group 'gnus-article-mime
+ :type 'function)
+
(defcustom gnus-page-delimiter "^\^L"
"*Regexp describing what to use as article page delimiters.
The default value is \"^\^L\", which is a form linefeed at the
:type 'regexp
:group 'gnus-article-various)
-(defcustom gnus-article-mode-line-format "Gnus: %g %S%m"
+(defcustom gnus-article-mode-line-format "Gnus: %g [%w] %S%m"
"*The format specification for the article mode line.
See `gnus-summary-mode-line-format' for a closer description.
:group 'gnus-article-signature)
(defface gnus-signature-face
- '((((type x))
- (:italic t)))
+ '((t (:italic t)))
"Face used for highlighting a signature in the article buffer."
:group 'gnus-article-highlight
:group 'gnus-article-signature)
(item :tag "skip" nil)
(face :value default)))))
-(defcustom gnus-article-decode-hook
- '(article-decode-charset article-decode-encoded-words)
+(defcustom gnus-article-decode-hook nil
"*Hook run to decode charsets in articles."
:group 'gnus-article-headers
:type 'hook)
("\221" "`")
("\222" "'")
("\223" "``")
- ("\224" "''")
+ ("\224" "\"")
("\225" "*")
("\226" "-")
- ("\227" "-")
+ ("\227" "--")
("\231" "(TM)")
("\233" ">")
("\234" "oe")
:type '(repeat regexp))
(defcustom gnus-unbuttonized-mime-types '(".*/.*")
- "List of MIME types that should not be given buttons when rendered."
+ "List of MIME types that should not be given buttons when rendered inline."
:group 'gnus-article-mime
:type '(repeat regexp))
:group 'gnus-article-headers
:type 'boolean)
+(defcustom gnus-article-mime-match-handle-function 'undisplayed-alternative
+ "Function called with a MIME handle as the argument.
+This is meant for people who want to view first matched part.
+For `undisplayed-alternative' (default), the first undisplayed
+part or alternative part is used. For `undisplayed', the first
+undisplayed part is used. For a function, the first part which
+the function return `t' is used. For `nil', the first part is
+used."
+ :group 'gnus-article-mime
+ :type '(choice
+ (item :tag "first" :value nil)
+ (item :tag "undisplayed" :value undisplayed)
+ (item :tag "undisplayed or alternative"
+ :value undisplayed-alternative)
+ (function)))
+
+(defcustom gnus-mime-action-alist
+ '(("save to file" . gnus-mime-save-part)
+ ("display as text" . gnus-mime-inline-part)
+ ("view the part" . gnus-mime-view-part)
+ ("pipe to command" . gnus-mime-pipe-part)
+ ("toggle display" . gnus-article-press-button)
+ ("view as type" . gnus-mime-view-part-as-type)
+ ("internalize type" . gnus-mime-internalize-part)
+ ("externalize type" . gnus-mime-externalize-part))
+ "An alist of actions that run on the MIME attachment."
+ :group 'gnus-article-mime
+ :type '(repeat (cons (string :tag "name")
+ (function))))
+
;;;
;;; The treatment variables
;;;
(const :tag "On" t)
(const :tag "Header" head)
(const :tag "Last" last)
+ (const :tag "Mime" mime)
(integer :tag "Less")
(repeat :tag "Groups" regexp)
(sexp :tag "Predicate")))
:type gnus-article-treat-custom)
(put 'gnus-treat-highlight-signature 'highlight t)
-(defcustom gnus-treat-buttonize 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."
:type gnus-article-treat-head-custom)
(put 'gnus-treat-buttonize-head 'highlight t)
-(defcustom gnus-treat-emphasize t
+(defcustom gnus-treat-emphasize nil
"Emphasize 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."
+ :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."
+ :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.
:group 'gnus-article-treat
:type gnus-article-treat-custom)
-(defcustom gnus-treat-strip-blank-lines nil
- "Strip all blank lines.
-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-overstrike t
"Treat overstrike highlighting.
Valid values are nil, t, `head', `last', an integer or a predicate.
:type gnus-article-treat-custom)
(put 'gnus-treat-overstrike 'highlight t)
-(defcustom gnus-treat-display-xface (if (and gnus-xemacs (featurep 'xface))
- 'head nil)
+(defcustom gnus-treat-display-xface
+ (and (or (and (fboundp 'image-type-available-p)
+ (image-type-available-p 'xbm))
+ (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."
:type gnus-article-treat-head-custom)
(put 'gnus-treat-display-xface 'highlight t)
-(defcustom gnus-treat-display-smileys (if (and gnus-xemacs
- (featurep 'xpm))
- t nil)
+(defcustom gnus-treat-display-smileys
+ (if (or (and (featurep 'xemacs)
+ (featurep 'xpm))
+ (and (fboundp 'image-type-available-p)
+ (image-type-available-p 'pbm))
+ (and (not (featurep 'xemacs))
+ window-system
+ (module-installed-p 'gnus-bitmap)))
+ t
+ nil)
"Display smileys.
Valid values are nil, t, `head', `last', an integer or a predicate.
See the manual for details."
:type gnus-article-treat-custom)
(put 'gnus-treat-display-smileys 'highlight t)
-(defcustom gnus-treat-display-picons (if gnus-xemacs 'head nil)
+(defcustom gnus-treat-display-picons (if (featurep 'xemacs) 'head nil)
"Display picons.
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-decode-article-as-default-mime-charset nil
+ "Decode an article as `default-mime-charset'. For instance, if you want to
+attempt to decode an article even if the value of `gnus-show-mime' is nil,
+you could set this variable to something like: nil for don't decode, t for
+decode the body, '(or header t) for the whole article, etc."
+ :group 'gnus-article-treat
+ :type '(radio (const :tag "Off" nil)
+ (const :tag "Decode body" t)
+ (const :tag "Decode all" (or head t))))
+
(defcustom gnus-treat-translate nil
"Translate articles from one language to another.
Valid values are nil, t, `head', `last', an integer or a predicate.
(defvar gnus-article-mime-handle-alist-1 nil)
(defvar gnus-treatment-function-alist
- '((gnus-treat-strip-banner gnus-article-strip-banner)
+ '((gnus-treat-decode-article-as-default-mime-charset
+ gnus-article-decode-article-as-default-mime-charset)
+ (gnus-treat-strip-banner gnus-article-strip-banner)
(gnus-treat-strip-headers-in-body gnus-article-strip-headers-in-body)
- (gnus-treat-highlight-signature gnus-article-highlight-signature)
(gnus-treat-buttonize gnus-article-add-buttons)
(gnus-treat-fill-article gnus-article-fill-cited-article)
(gnus-treat-fill-long-lines gnus-article-fill-long-lines)
(gnus-treat-strip-cr gnus-article-remove-cr)
- (gnus-treat-emphasize gnus-article-emphasize)
(gnus-treat-display-xface gnus-article-display-x-face)
(gnus-treat-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-strip-pgp gnus-article-hide-pgp)
(gnus-treat-strip-pem gnus-article-hide-pem)
(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-date-ut gnus-article-date-ut)
gnus-article-strip-leading-blank-lines)
(gnus-treat-strip-multiple-blank-lines
gnus-article-strip-multiple-blank-lines)
- (gnus-treat-strip-blank-lines gnus-article-strip-blank-lines)
(gnus-treat-overstrike gnus-article-treat-overstrike)
(gnus-treat-buttonize-head gnus-article-add-buttons-to-head)
- (gnus-treat-display-smileys gnus-smiley-display)
+ (gnus-treat-display-smileys gnus-article-smiley-display)
+ (gnus-treat-capitalize-sentences gnus-article-capitalize-sentences)
(gnus-treat-display-picons gnus-article-display-picons)
(gnus-treat-play-sounds gnus-earcon-display)))
(defun article-hide-headers (&optional arg delete)
"Hide unwanted headers and possibly sort them as well."
- (interactive)
- ;; This function might be inhibited.
+ (interactive (gnus-article-hidden-arg))
+ ;; Lars said that this function might be inhibited.
+ (if (gnus-article-check-hidden-text 'headers arg)
+ (progn
+ ;; Show boring headers as well.
+ (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)
(while (looking-at "From ")
(forward-line 1))
(unless (bobp)
- (delete-region (point-min) (point)))
+ (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
(message-sort-headers-1)
(when (setq beg (text-property-any
(point-min) (point-max) 'message-rank (+ 2 max)))
- ;; We delete the unwanted headers.
- (add-text-properties (point-min) (+ 5 (point-min))
- '(article-type headers dummy-invisible t))
- (delete-region beg (point-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))))))))
+ )
(defun article-hide-boring-headers (&optional arg)
"Toggle hiding of headers that aren't very interesting.
from reply-to
(ignore-errors
(equal
- (nth 1 (mail-extract-address-components from))
- (nth 1 (mail-extract-address-components reply-to)))))
+ (nth 1 (funcall gnus-extract-address-components from))
+ (nth 1 (funcall gnus-extract-address-components reply-to)))))
(gnus-article-hide-header "reply-to"))))
((eq elem 'date)
(let ((date (message-fetch-field "date")))
4))
(gnus-article-hide-header "date"))))
((eq elem 'long-to)
- (let ((to (message-fetch-field "to")))
+ (let ((to (message-fetch-field "to"))
+ (cc (message-fetch-field "cc")))
(when (> (length to) 1024)
- (gnus-article-hide-header "to"))))
+ (gnus-article-hide-header "to"))
+ (when (> (length cc) 1024)
+ (gnus-article-hide-header "cc"))))
((eq elem 'many-to)
- (let ((to-count 0))
+ (let ((to-count 0)
+ (cc-count 0))
(goto-char (point-min))
(while (re-search-forward "^to:" nil t)
(setq to-count (1+ to-count)))
(forward-line -1)
(narrow-to-region (point) (point-max))
(gnus-article-hide-header "to"))
- (setq to-count (1- to-count)))))))))))))
+ (setq to-count (1- to-count))))
+ (goto-char (point-min))
+ (while (re-search-forward "^cc:" nil t)
+ (setq cc-count (1+ cc-count)))
+ (when (> cc-count 1)
+ (while (> cc-count 0)
+ (goto-char (point-min))
+ (save-restriction
+ (re-search-forward "^cc:" nil nil cc-count)
+ (forward-line -1)
+ (narrow-to-region (point) (point-max))
+ (gnus-article-hide-header "cc"))
+ (setq cc-count (1- cc-count)))))))))))))
(defun gnus-article-hide-header (header)
(save-excursion
(point-max)))
'boring-headers))))
+(defun article-toggle-headers (&optional arg)
+ "Toggle hiding of headers. If given a negative prefix, always show;
+if given a positive prefix, always hide."
+ (interactive (gnus-article-hidden-arg))
+ (let ((force (when (numberp arg)
+ (cond ((> arg 0) 'always-hide)
+ ((< arg 0) 'always-show))))
+ (window (get-buffer-window gnus-article-buffer))
+ (header-end (point-min))
+ header-start field-end field-start
+ (inhibit-point-motion-hooks t)
+ (inhibit-read-only t)
+ buffer-read-only)
+ (save-restriction
+ (widen)
+ (while (and (setq header-start
+ (text-property-any header-end (point-max)
+ 'article-treated-header t))
+ (setq header-end
+ (text-property-not-all header-start (point-max)
+ 'article-treated-header t)))
+ (setq field-end header-start)
+ (cond
+ (;; Hide exposed invisible fields.
+ (and (not (eq 'always-show force))
+ (setq field-start
+ (text-property-any field-end header-end
+ 'exposed-invisible-field t)))
+ (while (and field-start
+ (setq field-end (text-property-not-all
+ field-start header-end
+ 'exposed-invisible-field t)))
+ (add-text-properties field-start field-end gnus-hidden-properties)
+ (setq field-start (text-property-any field-end header-end
+ 'exposed-invisible-field t)))
+ (put-text-property header-start header-end
+ 'exposed-invisible-field nil))
+ (;; Expose invisible fields.
+ (and (not (eq 'always-hide force))
+ (setq field-start
+ (text-property-any field-end header-end 'invisible t)))
+ (while (and field-start
+ (setq field-end (text-property-not-all
+ field-start header-end
+ '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
+ ;; 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.
+ (when (or (not (or (eq header-start field-start)
+ (eq ?\n (char-before field-start))))
+ (eq ?\n (char-before field-end)))
+ (remove-text-properties field-start field-end
+ gnus-hidden-properties)
+ (put-text-property field-start field-end
+ 'exposed-invisible-field t))
+ (setq field-start (text-property-any field-end header-end
+ 'invisible t))))
+ (;; Hide fields.
+ (not (eq 'always-show force))
+ (narrow-to-region header-start header-end)
+ (article-hide-headers)
+ ;; Re-display X-Face image under XEmacs.
+ (when (and (featurep 'xemacs)
+ (gnus-functionp gnus-article-x-face-command))
+ (let ((func (cadr (assq 'gnus-treat-display-xface
+ gnus-treatment-function-alist)))
+ (condition 'head))
+ (when (and (not gnus-inhibit-treatment)
+ func
+ (gnus-treat-predicate gnus-treat-display-xface))
+ (funcall func)
+ (put-text-property header-start header-end 'read-only nil))))
+ (widen))
+ ))
+ (goto-char (point-min))
+ (when window
+ (set-window-start window (point-min))))))
+
(defvar gnus-article-normalized-header-length 40
"Length of normalized headers.")
(let ((buffer-read-only nil))
(while (search-forward "\b" nil t)
(let ((next (char-after))
- (previous (char-after (- (point) 2))))
+ start end previous)
+ (backward-char 2)
+ (setq start (point)
+ previous (char-after))
+ (forward-char 3)
+ (setq end (point))
+ (backward-char)
;; We do the boldification/underlining by hiding the
;; overstrikes and putting the proper text property
;; on the letters.
(cond
((eq next previous)
- (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike)
- (put-text-property (point) (1+ (point)) 'face 'bold))
+ (gnus-article-hide-text-type start (point) 'overstrike)
+ (put-text-property (point) end 'face 'bold))
((eq next ?_)
(gnus-article-hide-text-type
(1- (point)) (1+ (point)) 'overstrike)
(put-text-property
- (- (point) 2) (1- (point)) 'face 'underline))
+ start (1- (point)) 'face 'underline))
((eq previous ?_)
- (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike)
+ (gnus-article-hide-text-type start (point) 'overstrike)
(put-text-property
- (point) (1+ (point)) 'face 'underline)))))))))
+ (point) end 'face 'underline)))))))))
(defun article-fill-long-lines ()
"Fill lines that are wider than the window width."
(not (string-match gnus-article-x-face-too-ugly
from))))
;; Has to be present.
- (re-search-forward "^X-Face: " nil t))
+ (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
"Decode charset-encoded text in the article.
If PROMPT (the prefix), prompt for a coding system to use."
(interactive "P")
+ (let ((inhibit-point-motion-hooks t) (case-fold-search t)
+ buffer-read-only
+ (mail-parse-charset gnus-newsgroup-charset)
+ (mail-parse-ignored-charsets
+ (save-excursion (condition-case nil
+ (set-buffer gnus-summary-buffer)
+ (error))
+ gnus-newsgroup-ignored-charsets))
+ ct cte ctl charset format)
(save-excursion
(save-restriction
(article-narrow-to-head)
- (let* ((inhibit-point-motion-hooks t)
- (case-fold-search t)
- (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))))
- (mail-parse-charset gnus-newsgroup-charset)
- (mail-parse-ignored-charsets
- (save-excursion (set-buffer gnus-summary-buffer)
- gnus-newsgroup-ignored-charsets))
- buffer-read-only)
- (goto-char (point-max))
- (widen)
- (forward-line 1)
- (narrow-to-region (point) (point-max))
- (when (and (or (not ctl)
- (equal (car ctl) "text/plain"))
- (not (mm-uu-test)))
- (mm-decode-body
- charset (and cte (intern (downcase
- (gnus-strip-whitespace cte))))
- (car ctl)))))))
+ (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 ((inhibit-point-motion-hooks t)
- (mail-parse-charset gnus-newsgroup-charset)
- (mail-parse-ignored-charsets
- (save-excursion (set-buffer gnus-summary-buffer)
- gnus-newsgroup-ignored-charsets))
- buffer-read-only)
- (save-restriction
- (article-narrow-to-head)
- (funcall gnus-decode-header-function (point-min) (point-max)))))
+ (let (buffer-read-only)
+ (let ((charset (save-excursion
+ (set-buffer gnus-summary-buffer)
+ default-mime-charset)))
+ (mime-decode-header-in-buffer charset)
+ )))
(defun article-de-quoted-unreadable (&optional force)
"Translate a quoted-printable-encoded article.
or not."
(interactive (list 'force))
(save-excursion
- (let ((buffer-read-only nil)
- (type (gnus-fetch-field "content-transfer-encoding"))
- (charset gnus-newsgroup-charset))
+ (let ((buffer-read-only nil) type charset)
+ (if (gnus-buffer-live-p gnus-original-article-buffer)
+ (with-current-buffer gnus-original-article-buffer
+ (setq type
+ (gnus-fetch-field "content-transfer-encoding"))
+ (let* ((ct (gnus-fetch-field "content-type"))
+ (ctl (and ct
+ (ignore-errors
+ (mail-header-parse-content-type ct)))))
+ (setq charset (and ctl
+ (mail-content-type-get ctl 'charset)))
+ (if (stringp charset)
+ (setq charset (intern (downcase charset)))))))
+ (unless charset
+ (setq charset gnus-newsgroup-charset))
+ (when (or force
+ (and type (let ((case-fold-search t))
+ (string-match "quoted-printable" type))))
+ (article-goto-body)
+ (quoted-printable-decode-region
+ (point) (point-max) (mm-charset-to-coding-system charset))))))
+
+(defun article-de-base64-unreadable (&optional force)
+ "Translate a base64 article.
+If FORCE, decode the article whether it is marked as base64 not."
+ (interactive (list 'force))
+ (save-excursion
+ (let ((buffer-read-only nil) type charset)
+ (if (gnus-buffer-live-p gnus-original-article-buffer)
+ (with-current-buffer gnus-original-article-buffer
+ (setq type
+ (gnus-fetch-field "content-transfer-encoding"))
+ (let* ((ct (gnus-fetch-field "content-type"))
+ (ctl (and ct
+ (ignore-errors
+ (mail-header-parse-content-type ct)))))
+ (setq charset (and ctl
+ (mail-content-type-get ctl 'charset)))
+ (if (stringp charset)
+ (setq charset (intern (downcase charset)))))))
+ (unless charset
+ (setq charset gnus-newsgroup-charset))
(when (or force
- (and type (string-match "quoted-printable" (downcase type))))
+ (and type (let ((case-fold-search t))
+ (string-match "base64" type))))
(article-goto-body)
(save-restriction
(narrow-to-region (point) (point-max))
- (quoted-printable-decode-region (point-min) (point-max))
- (when charset
- (mm-decode-body charset)))))))
+ (base64-decode-region (point-min) (point-max))
+ (mm-decode-coding-region
+ (point-min) (point-max) (mm-charset-to-coding-system charset)))))))
+
+(eval-when-compile
+ (require 'rfc1843))
+
+(defun article-decode-HZ ()
+ "Translate a HZ-encoded article."
+ (interactive)
+ (require 'rfc1843)
+ (save-excursion
+ (let ((buffer-read-only nil))
+ (rfc1843-decode-region (point-min) (point-max)))))
+
+(defun article-wash-html ()
+ "Format an html article."
+ (interactive)
+ (save-excursion
+ (let ((buffer-read-only nil)
+ charset)
+ (if (gnus-buffer-live-p gnus-original-article-buffer)
+ (with-current-buffer gnus-original-article-buffer
+ (let* ((ct (gnus-fetch-field "content-type"))
+ (ctl (and ct
+ (ignore-errors
+ (mail-header-parse-content-type ct)))))
+ (setq charset (and ctl
+ (mail-content-type-get ctl 'charset)))
+ (if (stringp charset)
+ (setq charset (intern (downcase 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))))))))
+
+(defun article-hide-list-identifiers ()
+ "Remove list identifies from the Subject header.
+The `gnus-list-identifiers' variable specifies what to do."
+ (interactive)
+ (save-excursion
+ (save-restriction
+ (let ((inhibit-point-motion-hooks t)
+ buffer-read-only)
+ (article-narrow-to-head)
+ (let ((regexp (if (stringp gnus-list-identifiers) gnus-list-identifiers
+ (mapconcat 'identity gnus-list-identifiers " *\\|"))))
+ (when regexp
+ (goto-char (point-min))
+ (when (re-search-forward
+ (concat "^Subject: +\\(\\(\\(Re: +\\)?\\(" regexp
+ " *\\)\\)+\\(Re: +\\)?\\)")
+ nil t)
+ (let ((s (or (match-string 3) (match-string 5))))
+ (delete-region (match-beginning 1) (match-end 1))
+ (when s
+ (goto-char (match-beginning 1))
+ (insert s))))))))))
(defun article-hide-pgp ()
"Remove any PGP headers and signatures in the current article."
(when (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\n" nil t)
(push 'pgp gnus-article-wash-types)
(delete-region (match-beginning 0) (match-end 0))
- ;; PGP 5 and GNU PG add a `Hash: <>' comment, hide that too
- (when (looking-at "Hash:.*$")
- (delete-region (point) (1+ (gnus-point-at-eol))))
+ ;; Remove armor headers (rfc2440 6.2)
+ (delete-region (point) (or (re-search-forward "^[ \t]*\n" nil t)
+ (point)))
(setq beg (point))
;; Hide the actual signature.
(and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t)
(save-excursion
(save-restriction
(let ((inhibit-point-motion-hooks t)
- (banner (gnus-group-get-parameter gnus-newsgroup-name 'banner))
+ (banner (gnus-group-find-parameter gnus-newsgroup-name 'banner))
(gnus-signature-limit nil)
buffer-read-only beg end)
(when banner
(widen)
(forward-line -1)
(delete-region (point) (point-max))))
+ ((symbolp banner)
+ (if (setq banner (cdr (assq banner gnus-article-banner-alist)))
+ (while (re-search-forward banner nil t)
+ (delete-region (match-beginning 0) (match-end 0)))))
((stringp banner)
(while (re-search-forward banner nil t)
(delete-region (match-beginning 0) (match-end 0))))))))))
-(defun article-babel-prompt ()
- "Prompt for a babel translation."
- (require 'babel)
- (completing-read "Translate from: "
- babel-translations nil t
- (car (car babel-translations))
- babel-history))
-
-(defun article-babel (translation)
- "Translate article according to TRANSLATION using babelfish."
- (interactive (list (article-babel-prompt)))
+(defun article-babel ()
+ "Translate article using an online translation service."
+ (interactive)
(require 'babel)
(save-excursion
(set-buffer gnus-article-buffer)
(let* ((buffer-read-only nil)
(start (point))
(end (point-max))
- (msg (buffer-substring start end)))
+ (orig (buffer-substring start end))
+ (trans (babel-as-string orig)))
(save-restriction
(narrow-to-region start end)
(delete-region start end)
- (babel-fetch msg (cdr (assoc translation babel-translations)))
- (save-restriction
- (narrow-to-region start (point-max))
- (babel-wash)))))))
+ (insert trans))))))
(defun article-hide-signature (&optional arg)
"Hide the signature in the current article.
If given a negative prefix, always show; if given a positive prefix,
always hide."
(interactive (gnus-article-hidden-arg))
- (unless (gnus-article-check-hidden-text 'signature arg)
- (save-excursion
- (save-restriction
- (let ((buffer-read-only nil))
- (when (gnus-article-narrow-to-signature)
- (gnus-article-hide-text-type
- (point-min) (point-max) 'signature)))))))
+ (save-excursion
+ (save-restriction
+ (if (interactive-p)
+ (progn
+ (widen)
+ (article-goto-body))
+ (goto-char (point-min)))
+ (unless (gnus-article-check-hidden-text 'signature arg)
+ (let ((buffer-read-only nil)
+ (button (point)))
+ (while (setq button (text-property-any button (point-max)
+ 'gnus-callback
+ 'gnus-signature-toggle))
+ (setq button (text-property-not-all button (point-max)
+ 'gnus-callback
+ 'gnus-signature-toggle))
+ (when (and button (not (eobp)))
+ (gnus-article-hide-text-type
+ (1+ button)
+ (next-single-property-change (1+ button) 'mime-view-entity
+ nil (point-max))
+ 'signature))))))))
(defun article-strip-headers-in-body ()
"Strip offensive headers from bodies."
(defun article-date-ut (&optional type highlight header)
"Convert DATE date to universal time in the current article.
If TYPE is `local', convert to local time; if it is `lapsed', output
-how much time has lapsed since DATE. For `lapsed', the value of
+how much time has lapsed since DATE. For `lapsed', the value of
`gnus-article-date-lapsed-new-header' says whether the \"X-Sent:\" header
should replace the \"Date:\" one, or should be added below it."
(interactive (list 'ut t))
(let* ((header (or header
- (mail-header-date (save-excursion
- (set-buffer gnus-summary-buffer)
- gnus-current-headers))
+ (and (eq 1 (point-min))
+ (mail-header-date (save-excursion
+ (set-buffer gnus-summary-buffer)
+ gnus-current-headers)))
(message-fetch-field "date")
""))
- (tdate-regexp "^Date:[ \t]\\|^X-Sent:[ \t]")
- (date-regexp
- (cond
- ((not gnus-article-date-lapsed-new-header)
- tdate-regexp)
- ((eq type 'lapsed)
- "^X-Sent:[ \t]")
- (t
- "^Date:[ \t]")))
(date (if (vectorp header) (mail-header-date header)
header))
(inhibit-point-motion-hooks t)
- (newline t)
- bface eface)
+ bface eface date-pos)
(when (and date (not (string= date "")))
(save-excursion
(save-restriction
(article-narrow-to-head)
- (when (re-search-forward tdate-regexp nil t)
+ (when (or (and (eq type 'lapsed)
+ gnus-article-date-lapsed-new-header
+ ;; Attempt to get the face of X-Sent first.
+ (re-search-forward "^X-Sent:[ \t]" nil t))
+ (re-search-forward "^Date:[ \t]" nil t)
+ ;; If Date is missing, try again for X-Sent.
+ (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)
eface (get-text-property (1- (gnus-point-at-eol))
- 'face))
- (forward-line 1))
- (goto-char (point-min))
+ 'face)))
(let ((buffer-read-only nil))
- ;; Delete any old Date headers.
- (while (re-search-forward date-regexp nil t)
- (if newline
- (delete-region (progn (beginning-of-line) (point))
- (progn (end-of-line) (point)))
- (delete-region (progn (beginning-of-line) (point))
- (progn (forward-line 1) (point))))
- (setq newline nil))
- (if (re-search-forward tdate-regexp nil t)
- (forward-line 1))
+ ;; Delete any old X-Sent headers.
+ (when (setq date-pos
+ (text-property-any (point-min) (point-max)
+ 'article-date-lapsed t))
+ (goto-char (setq date-pos (set-marker (make-marker) date-pos)))
+ (delete-region (match-beginning 0)
+ (progn (forward-line 1) (point))))
+ (goto-char (point-min))
+ ;; Delete any old Date headers.
+ (while (re-search-forward "^Date:[ \t]" nil t)
+ (unless date-pos
+ (setq date-pos (match-beginning 0)))
+ (unless (and (eq type 'lapsed)
+ gnus-article-date-lapsed-new-header)
+ (delete-region (match-beginning 0)
+ (progn (message-next-header) (point)))))
+ (if date-pos
+ (progn
+ (goto-char date-pos)
+ (unless (bolp)
+ ;; Possibly, Date has been deleted.
+ (insert "\n"))
+ (when (and (eq type 'lapsed)
+ gnus-article-date-lapsed-new-header
+ (looking-at "Date:"))
+ (forward-line 1)))
+ (goto-char (point-min)))
(insert (article-make-date-line date type))
- (when newline
- (insert "\n")
- (forward-line -1))
+ (when (eq type 'lapsed)
+ (put-text-property (gnus-point-at-bol) (point)
+ 'article-date-lapsed t))
+ (insert "\n")
+ (forward-line -1)
;; Do highlighting.
- (beginning-of-line)
(when (looking-at "\\([^:]+\\): *\\(.*\\)$")
(put-text-property (match-beginning 1) (1+ (match-end 1))
+ 'original-date date)
+ (put-text-property (match-beginning 1) (1+ (match-end 1))
'face bface)
(put-text-property (match-beginning 2) (match-end 2)
'face eface))))))))
;; functions since they aren't particularly resistant to
;; buggy dates.
((eq type 'local)
- (let ((tz (car (current-time-zone))))
- (format "Date: %s %s%04d" (current-time-string time)
- (if (> tz 0) "+" "-") (abs (/ tz 36)))))
+ (let ((tz (car (current-time-zone time))))
+ (format "Date: %s %s%02d%02d" (current-time-string time)
+ (if (> tz 0) "+" "-") (/ (abs tz) 3600)
+ (/ (% (abs tz) 3600) 60))))
;; Convert to Universal Time.
((eq type 'ut)
(concat "Date: "
(current-time-string
(let* ((e (parse-time-string date))
- (tm (apply 'encode-time e))
- (ms (car tm))
- (ls (- (cadr tm) (car (current-time-zone)))))
+ (tm (apply 'encode-time e))
+ (ms (car tm))
+ (ls (- (cadr tm) (car (current-time-zone time)))))
(cond ((< ls 0) (list (1- ms) (+ ls 65536)))
((> ls 65535) (list (1+ ms) (- ls 65536)))
(t (list ms ls)))))
(format-time-string gnus-article-time-format time))))
;; ISO 8601.
((eq type 'iso8601)
- (concat
- "Date: "
- (format-time-string "%Y%m%dT%H%M%S" time)))
+ (let ((tz (car (current-time-zone time))))
+ (concat
+ "Date: "
+ (format-time-string "%Y%m%dT%H%M%S" time)
+ (format "%s%02d%02d"
+ (if (> tz 0) "+" "-") (/ (abs tz) 3600)
+ (/ (% (abs tz) 3600) 60)))))
;; Do an X-Sent lapsed format.
((eq type 'lapsed)
;; If the date is seriously mangled, the timezone functions are
"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-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."
+ (interactive)
+ (save-excursion
+ (save-restriction
+ (widen)
+ (article-narrow-to-head)
+ (let ((buffer-read-only nil))
+ (gnus-article-unhide-text (point-min) (point-max))))))
(defun article-emphasize (&optional arg)
"Emphasize text according to `gnus-emphasis-alist'."
(interactive (gnus-article-hidden-arg))
(unless (gnus-article-check-hidden-text 'emphasis arg)
(save-excursion
- (let ((alist (or gnus-article-emphasis-alist gnus-emphasis-alist))
+ (let ((alist (or
+ (condition-case nil
+ (with-current-buffer gnus-summary-buffer
+ gnus-article-emphasis-alist)
+ (error))
+ gnus-emphasis-alist))
(buffer-read-only nil)
(props (append '(article-type emphasis)
gnus-hidden-properties))
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
(let ((name (and gnus-newsgroup-name
(gnus-group-real-name gnus-newsgroup-name))))
(make-local-variable 'gnus-article-emphasis-alist)
- (setq gnus-article-emphasis-alist
- (nconc
+ (setq gnus-article-emphasis-alist
+ (nconc
(let ((alist gnus-group-highlight-words-alist) elem highlight)
(while (setq elem (pop alist))
(when (and name (string-match (car elem) name))
(setq alist nil
- highlight (copy-list (cdr elem)))))
+ highlight (copy-sequence (cdr elem)))))
highlight)
- (copy-list highlight-words)
+ (copy-sequence highlight-words)
(if gnus-newsgroup-name
- (copy-list (gnus-group-find-parameter
- gnus-newsgroup-name 'highlight-words t)))
+ (copy-sequence (gnus-group-find-parameter
+ gnus-newsgroup-name 'highlight-words t)))
gnus-emphasis-alist)))))
(defvar gnus-summary-article-menu)
(let ((default-name
(funcall function group headers (symbol-value variable)))
result)
- (setq
- result
+ (setq result
+ (expand-file-name
(cond
((eq filename 'default)
default-name)
(gnus-make-directory (file-name-directory file))
;; If we have read a directory, we append the default file name.
(when (file-directory-p file)
- (setq file (concat (file-name-as-directory file)
- (file-name-nondirectory default-name))))
+ (setq file (expand-file-name (file-name-nondirectory default-name)
+ (file-name-as-directory file))))
;; Possibly translate some characters.
- (nnheader-translate-file-chars file)))))
+ (nnheader-translate-file-chars file))))))
(gnus-make-directory (file-name-directory result))
(set variable result)))
default
(or last-file default))))
-(defun gnus-Plain-save-name (newsgroup headers &optional last-file)
- "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
-If variable `gnus-use-long-file-name' is non-nil, it is
-~/News/News.group. Otherwise, it is like ~/News/news/group/news."
- (or last-file
- (expand-file-name
- (if (gnus-use-long-file-name 'not-save)
- (gnus-capitalize-newsgroup newsgroup)
- (concat (gnus-newsgroup-directory-form newsgroup) "/news"))
- gnus-article-save-directory)))
-
(defun gnus-plain-save-name (newsgroup headers &optional last-file)
"Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
If variable `gnus-use-long-file-name' is non-nil, it is
(expand-file-name
(if (gnus-use-long-file-name 'not-save)
newsgroup
- (concat (gnus-newsgroup-directory-form newsgroup) "/news"))
+ (expand-file-name "news" (gnus-newsgroup-directory-form newsgroup)))
gnus-article-save-directory)))
(eval-and-compile
gfunc (cdr func))
(setq afunc func
gfunc (intern (format "gnus-%s" func))))
- (fset gfunc
- (if (not (fboundp afunc))
- nil
- `(lambda (&optional interactive &rest args)
- ,(documentation afunc t)
- (interactive (list t))
- (save-excursion
- (set-buffer gnus-article-buffer)
- (if interactive
- (call-interactively ',afunc)
- (apply ',afunc args))))))))
+ (defalias gfunc
+ (if (fboundp afunc)
+ `(lambda (&optional interactive &rest args)
+ ,(documentation afunc t)
+ (interactive (list t))
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (if interactive
+ (call-interactively ',afunc)
+ (apply ',afunc args))))))))
'(article-hide-headers
article-hide-boring-headers
+ article-toggle-headers
article-treat-overstrike
article-fill-long-lines
article-capitalize-sentences
article-remove-cr
article-display-x-face
article-de-quoted-unreadable
- article-mime-decode-quoted-printable
+ article-de-base64-unreadable
+ article-decode-HZ
+ article-wash-html
+ article-hide-list-identifiers
article-hide-pgp
article-strip-banner
article-babel
article-emphasize
article-treat-dumbquotes
article-normalize-headers
- (article-show-all . gnus-article-show-all-headers))))
+ (article-show-all-headers . gnus-article-show-all-headers)
+ (article-show-all . gnus-article-show-all))))
\f
;;;
;;; Gnus article mode
(put 'gnus-article-mode 'mode-class 'special)
-(set-keymap-parent gnus-article-mode-map widget-keymap)
-
(gnus-define-keys gnus-article-mode-map
" " gnus-article-goto-next-page
"\177" gnus-article-goto-prev-page
"s" gnus-article-show-summary
"\C-c\C-m" gnus-article-mail
"?" gnus-article-describe-briefly
- "e" gnus-article-edit
+ "e" gnus-summary-edit-article
"<" beginning-of-buffer
">" end-of-buffer
"\C-c\C-i" gnus-info-find-node
"\M-^" gnus-article-read-summary-keys
"\M-g" gnus-article-read-summary-keys)
-(substitute-key-definition
- 'undefined 'gnus-article-read-summary-keys gnus-article-mode-map)
+;; Define almost undefined keys to `gnus-article-read-summary-keys'.
+(mapcar
+ (lambda (key)
+ (unless (lookup-key gnus-article-mode-map key)
+ (define-key gnus-article-mode-map key
+ 'gnus-article-read-summary-keys)))
+ (delq nil
+ (append
+ (mapcar
+ (lambda (elt)
+ (let ((key (car elt)))
+ (and (> (length key) 0)
+ (not (eq 'menu-bar (aref key 0)))
+ (symbolp (lookup-key gnus-summary-mode-map key))
+ key)))
+ (accessible-keymaps gnus-summary-mode-map))
+ (let ((c 127)
+ keys)
+ (while (>= c 32)
+ (push (char-to-string c) keys)
+ (decf c))
+ keys))))
(defun gnus-article-make-menu-bar ()
(gnus-turn-off-edit-menu 'article)
(easy-menu-define
gnus-article-treatment-menu gnus-article-mode-map ""
'("Treatment"
- ["Hide headers" gnus-article-hide-headers t]
+ ["Hide headers" gnus-article-toggle-headers t]
["Hide signature" gnus-article-hide-signature t]
["Hide citation" gnus-article-hide-citation t]
["Treat overstrike" gnus-article-treat-overstrike t]
["Remove carriage return" gnus-article-remove-cr t]
- ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t]))
+ ["Decode HZ" gnus-article-decode-HZ t]))
;; Note "Commands" menu is defined in gnus-sum.el for consistency
(setq mode-name "Article")
(setq major-mode 'gnus-article-mode)
(make-local-variable 'minor-mode-alist)
+ (unless (assq 'gnus-show-mime minor-mode-alist)
+ (push (list 'gnus-show-mime " MIME") minor-mode-alist))
(use-local-map gnus-article-mode-map)
(gnus-update-format-specifications nil 'article-mode)
(set (make-local-variable 'page-delimiter) gnus-page-delimiter)
(make-local-variable 'gnus-article-mime-handles)
(make-local-variable 'gnus-article-decoded-p)
(make-local-variable 'gnus-article-mime-handle-alist)
- (make-local-variable 'gnus-article-washed-types)
+ (make-local-variable 'gnus-article-wash-types)
(gnus-set-default-directory)
(buffer-disable-undo)
(setq buffer-read-only t)
(set-syntax-table gnus-article-mode-syntax-table)
- (mm-enable-multibyte)
(gnus-run-hooks 'gnus-article-mode-hook))
(defun gnus-article-setup-buffer ()
;; Init original article buffer.
(save-excursion
(set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
- (mm-enable-multibyte)
+ (set-buffer-multibyte nil)
(setq major-mode 'gnus-original-article-mode)
(make-local-variable 'gnus-original-article))
(if (get-buffer name)
(forward-line line)
(point)))))
+;;; @@ article filters
+;;;
+
+(defun gnus-article-display-mime-message ()
+ "Article display method for MIME message."
+ ;; called from `gnus-original-article-buffer'.
+ (let (charset all-headers)
+ (with-current-buffer gnus-summary-buffer
+ (setq charset default-mime-charset
+ all-headers gnus-have-all-headers))
+ (make-local-variable 'default-mime-charset)
+ (setq default-mime-charset charset)
+ (with-current-buffer (get-buffer-create gnus-article-buffer)
+ (make-local-variable 'default-mime-charset)
+ (setq default-mime-charset charset))
+ (mime-display-message mime-message-structure
+ gnus-article-buffer nil gnus-article-mode-map)
+ (when all-headers
+ (gnus-article-hide-headers nil -1)))
+ (run-hooks 'gnus-mime-article-prepare-hook))
+
+(defun gnus-article-display-traditional-message ()
+ "Article display method for traditional message."
+ (set-buffer gnus-article-buffer)
+ (let (buffer-read-only)
+ (erase-buffer)
+ (insert-buffer-substring gnus-original-article-buffer)))
+
+(defun gnus-article-make-full-mail-header (&optional number charset)
+ "Create a new mail header structure in a raw article buffer."
+ (unless (and number charset)
+ (save-current-buffer
+ (set-buffer gnus-summary-buffer)
+ (unless number
+ (setq number (or (cdr gnus-article-current) 0)))
+ (unless charset
+ (setq charset (or default-mime-charset 'x-ctext)))))
+ (goto-char (point-min))
+ (let ((header-end (if (search-forward "\n\n" nil t)
+ (1- (point))
+ (goto-char (point-max))))
+ (chars (- (point-max) (point)))
+ (lines (count-lines (point) (point-max)))
+ (default-mime-charset charset)
+ xref)
+ (narrow-to-region (point-min) header-end)
+ (setq xref (std11-fetch-field "xref"))
+ (prog1
+ (make-full-mail-header
+ number
+ (std11-fetch-field "subject")
+ (std11-fetch-field "from")
+ (std11-fetch-field "date")
+ (std11-fetch-field "message-id")
+ (std11-fetch-field "references")
+ chars
+ lines
+ (when xref (concat "Xref: " xref)))
+ (widen))))
+
(defun gnus-article-prepare (article &optional all-headers header)
"Prepare ARTICLE in article mode buffer.
ARTICLE should either be an article number or a Message-ID.
result)
(save-excursion
(gnus-article-setup-buffer)
- (set-buffer gnus-article-buffer)
+ (set-buffer gnus-original-article-buffer)
;; Deactivate active regions.
(when (and (boundp 'transient-mark-mode)
transient-mark-mode)
(message "Message marked for downloading"))
(gnus-summary-mark-article article gnus-canceled-mark)
(unless (memq article gnus-newsgroup-sparse)
- (gnus-error 1
- "No such article (may have expired or been canceled)")))))
+ (gnus-error 1 "No such article (may have expired or been canceled)")))))
(if (or (eq result 'pseudo)
(eq result 'nneething))
(progn
(gnus-set-global-variables)
(setq gnus-have-all-headers
(or all-headers gnus-show-all-headers))))
+ (save-excursion
+ (gnus-configure-windows 'article))
(when (or (numberp article)
(stringp article))
(gnus-article-prepare-display)
(gnus-configure-windows 'article)
t))))))
+(defun gnus-article-prepare-mime-display (&optional number)
+ (goto-char (point-min))
+ (when (re-search-forward "^[^\t ]+:" nil t)
+ (goto-char (match-beginning 0)))
+ (let ((entity (if (eq 1 (point-min))
+ (get-text-property 1 'mime-view-entity)
+ (get-text-property (point) 'mime-view-entity)))
+ last-entity child-entity next type)
+ (setq child-entity (mime-entity-children entity))
+ (if child-entity
+ (setq last-entity (nth (1- (length child-entity))
+ child-entity))
+ (setq last-entity entity))
+ (save-restriction
+ (narrow-to-region (point)
+ (if (search-forward "\n\n" nil t)
+ (point)
+ (point-max)))
+ (gnus-treat-article 'head)
+ (put-text-property (point-min) (point-max) 'article-treated-header t)
+ (goto-char (point-max)))
+ (while (and (not (eobp)) entity)
+ (setq next (set-marker
+ (make-marker)
+ (next-single-property-change (point) 'mime-view-entity
+ nil (point-max))))
+ (let ((types (mime-entity-content-type entity)))
+ (while (eq 'multipart (mime-content-type-primary-type types))
+ (setq entity (car (mime-entity-children entity))
+ types (mime-entity-content-type entity)))
+ (when types
+ (setq type (format "%s/%s"
+ (mime-content-type-primary-type types)
+ (mime-content-type-subtype types)))))
+ (if (string-equal type "message/rfc822")
+ (progn
+ (setq next (point))
+ (let ((children (mime-entity-children entity))
+ last-children)
+ (when children
+ (setq last-children (nth (1- (length children)) children))
+ (while
+ (and
+ (not (eq last-children
+ (get-text-property next 'mime-view-entity)))
+ (setq next
+ (next-single-property-change next
+ 'mime-view-entity
+ nil (point-max)))))))
+ (setq next (next-single-property-change next 'mime-view-entity
+ nil (point-max)))
+ (save-restriction
+ (narrow-to-region (point) next)
+ (gnus-article-prepare-mime-display)
+ (goto-char (point-max)))
+ (setq entity (get-text-property (point) 'mime-view-entity)))
+ (save-restriction
+ (narrow-to-region (point) next)
+ ;; Kludge. We have to count true number, but for now,
+ ;; part number is here only to achieve `last'.
+ (gnus-treat-article nil 1
+ (if (eq entity last-entity)
+ 1 2)
+ type)
+ (goto-char (point-max)))
+ (setq entity (get-text-property next 'mime-view-entity))))))
+
;;;###autoload
(defun gnus-article-prepare-display ()
"Make the current buffer look like a nice article."
- ;; Hooks for getting information from the article.
- ;; This hook must be called before being narrowed.
- (let ((gnus-article-buffer (current-buffer))
+ (setq gnus-article-wash-types nil)
+ (gnus-run-hooks 'gnus-tmp-internal-hook)
+ (gnus-run-hooks 'gnus-article-prepare-hook)
+ ;; Display message.
+ (let (mime-display-header-hook mime-display-text/plain-hook)
+ (funcall (if gnus-show-mime
+ (progn
+ (setq mime-message-structure gnus-current-headers)
+ (mime-buffer-entity-set-buffer-internal
+ mime-message-structure
+ gnus-original-article-buffer)
+ (mime-entity-set-representation-type-internal
+ mime-message-structure 'mime-buffer-entity)
+ (luna-send mime-message-structure
+ 'initialize-instance
+ mime-message-structure)
+ gnus-article-display-method-for-mime)
+ 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)
- (unless (eq major-mode 'gnus-article-mode)
- (gnus-article-mode))
- (setq buffer-read-only nil)
- (gnus-run-hooks 'gnus-tmp-internal-hook)
- (gnus-run-hooks 'gnus-article-prepare-hook)
- (when gnus-display-mime-function
- (funcall gnus-display-mime-function))))
+ (save-restriction
+ (widen)
+ (if gnus-show-mime
+ (gnus-article-prepare-mime-display)
+ (narrow-to-region (goto-char (point-min))
+ (if (search-forward "\n\n" nil t)
+ (point)
+ (point-max)))
+ (gnus-treat-article 'head)
+ (put-text-property (point-min) (point-max) 'article-treated-header t)
+ (goto-char (point-max))
+ (widen)
+ (narrow-to-region (point) (point-max))
+ (gnus-treat-article nil))
+ (put-text-property (point-min) (point-max) 'read-only nil)))
+ ;; Perform the article display hooks. Incidentally, this hook is
+ ;; an obsolete variable by now.
+ (gnus-run-hooks 'gnus-article-display-hook))
+
+(defun gnus-article-decode-article-as-default-mime-charset ()
+ "Decode an article as `default-mime-charset'. It won't work if the
+value of the variable `gnus-show-mime' is non-nil."
+ (unless gnus-show-mime
+ (decode-mime-charset-region (point-min) (point-max)
+ (with-current-buffer gnus-summary-buffer
+ default-mime-charset))))
;;;
;;; Gnus MIME viewing functions
(?e gnus-tmp-dots ?s)))
(defvar gnus-mime-button-commands
- '((gnus-article-press-button "\r" "Toggle Display")
- (gnus-mime-view-part "v" "View Interactively...")
- (gnus-mime-save-part "o" "Save...")
- (gnus-mime-copy-part "c" "View As Text, In Other Buffer")
- (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-pipe-part "|" "Pipe To Command...")))
+ '((gnus-article-press-button "\r" "Toggle Display")
+ (gnus-mime-view-part "v" "View Interactively...")
+ (gnus-mime-view-part-as-type "t" "View As Type...")
+ (gnus-mime-save-part "o" "Save...")
+ (gnus-mime-copy-part "c" "View As Text, In Other Buffer")
+ (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-pipe-part "|" "Pipe To Command...")
+ (gnus-mime-action-on-part "." "Take action on the part")))
(defun gnus-article-mime-part-status ()
- (if gnus-article-mime-handle-alist-1
- (format " (%d parts)" (length gnus-article-mime-handle-alist-1))
- ""))
-
-(defvar gnus-mime-button-map nil)
-(unless gnus-mime-button-map
- (setq gnus-mime-button-map (make-sparse-keymap))
- (set-keymap-parent gnus-mime-button-map gnus-article-mode-map)
- (define-key gnus-mime-button-map gnus-mouse-2 'gnus-article-push-button)
- (define-key gnus-mime-button-map gnus-down-mouse-3 'gnus-mime-button-menu)
- (mapcar (lambda (c)
- (define-key gnus-mime-button-map (cadr c) (car c)))
- gnus-mime-button-commands))
+ (with-current-buffer gnus-article-buffer
+ (let ((entity (get-text-property (point-min) 'mime-view-entity)))
+ (if (and entity (mime-entity-children entity))
+ (format " (%d parts)" (length (mime-entity-children entity)))
+ ""))))
+
+(defvar gnus-mime-button-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map gnus-article-mode-map)
+ (define-key map gnus-mouse-2 'gnus-article-push-button)
+ (define-key map gnus-down-mouse-3 'gnus-mime-button-menu)
+ (dolist (c gnus-mime-button-commands)
+ (define-key map (cadr c) (car c)))
+ map))
(defun gnus-mime-button-menu (event)
"Construct a context-sensitive menu of MIME commands."
(cons (caddr c) (car c)))
gnus-mime-button-commands))))))
(if response
- (funcall response))))))
+ (call-interactively response))))))
(defun gnus-mime-view-all-parts (&optional handles)
"View all the MIME parts."
(mm-pipe-part data)))
(defun gnus-mime-view-part ()
- "Interactively choose a view method for the MIME part under point."
+ "Interactively choose a viewing method for the MIME part under point."
(interactive)
(gnus-article-check-buffer)
(let ((data (get-text-property (point) 'gnus-data)))
(mm-interactively-view-part data)))
+(defun gnus-mime-view-part-as-type-internal ()
+ (gnus-article-check-buffer)
+ (let* ((name (mail-content-type-get
+ (mm-handle-type (get-text-property (point) 'gnus-data))
+ 'name))
+ (def-type (and name (mm-default-file-encoding name))))
+ (and def-type (cons def-type 0))))
+
+(defun gnus-mime-view-part-as-type (mime-type)
+ "Choose a MIME media type, and view the part as such."
+ (interactive
+ (list (completing-read
+ "View as MIME type: "
+ (mapcar #'list (mailcap-mime-types))
+ nil nil
+ (gnus-mime-view-part-as-type-internal))))
+ (gnus-article-check-buffer)
+ (let ((handle (get-text-property (point) 'gnus-data)))
+ (gnus-mm-display-part
+ (mm-make-handle (mm-handle-buffer handle)
+ (cons mime-type (cdr (mm-handle-type handle)))
+ (mm-handle-encoding handle)
+ (mm-handle-undisplayer handle)
+ (mm-handle-disposition handle)
+ (mm-handle-description handle)
+ (mm-handle-cache handle)
+ (mm-handle-id handle)))))
+
(defun gnus-mime-copy-part (&optional handle)
"Put the the MIME part under point into a new buffer."
(interactive)
(setq buffer-file-name nil))
(goto-char (point-min))))
-(defun gnus-mime-inline-part (&optional handle)
+(defun gnus-mime-inline-part (&optional handle arg)
"Insert the MIME part under point into the current buffer."
- (interactive)
+ (interactive (list nil current-prefix-arg))
(gnus-article-check-buffer)
(let* ((handle (or handle (get-text-property (point) 'gnus-data)))
- contents
+ contents charset
(b (point))
buffer-read-only)
(if (mm-handle-undisplayer handle)
(mm-remove-part handle)
(setq contents (mm-get-part handle))
+ (cond
+ ((not arg)
+ (setq charset (or (mail-content-type-get
+ (mm-handle-type handle) 'charset)
+ gnus-newsgroup-charset)))
+ ((numberp arg)
+ (setq charset
+ (or (cdr (assq arg
+ gnus-summary-show-article-charset-alist))
+ (read-coding-system "Charset: ")))))
(forward-line 2)
- (mm-insert-inline handle contents)
+ (mm-insert-inline handle
+ (if (and charset
+ (setq charset (mm-charset-to-coding-system
+ charset))
+ (not (eq charset 'ascii)))
+ (mm-decode-coding-string contents charset)
+ contents))
(goto-char b))))
(defun gnus-mime-externalize-part (&optional handle)
(gnus-article-check-buffer)
(let* ((handle (or handle (get-text-property (point) 'gnus-data)))
(mm-user-display-methods nil)
- (mm-all-images-fit t)
+ (mm-inlined-types nil)
(mail-parse-charset gnus-newsgroup-charset)
(mail-parse-ignored-charsets
(save-excursion (set-buffer gnus-summary-buffer)
(mm-display-part handle))))
(defun gnus-mime-internalize-part (&optional handle)
- "View the MIME part under point with an internal viewer."
+ "View the MIME part under point with an internal viewer.
+In no internal viewer is available, use an external viewer."
(interactive)
(gnus-article-check-buffer)
(let* ((handle (or handle (get-text-property (point) 'gnus-data)))
- (mm-user-display-methods '((".*" . inline)))
- (mm-all-images-fit t)
+ (mm-inlined-types '(".*"))
+ (mm-inline-large-images t)
(mail-parse-charset gnus-newsgroup-charset)
(mail-parse-ignored-charsets
(save-excursion (set-buffer gnus-summary-buffer)
(mm-remove-part handle)
(mm-display-part handle))))
+(defun gnus-mime-action-on-part (&optional action)
+ "Do something with the MIME attachment at \(point\)."
+ (interactive
+ (list (completing-read "Action: " gnus-mime-action-alist)))
+ (gnus-article-check-buffer)
+ (let ((action-pair (assoc action gnus-mime-action-alist)))
+ (if action-pair
+ (funcall (cdr action-pair)))))
+
+
(defun gnus-article-part-wrapper (n function)
(save-current-buffer
(set-buffer gnus-article-buffer)
(interactive "p")
(gnus-article-part-wrapper n 'gnus-mime-inline-part))
-(defun gnus-article-view-part (n)
+(defun gnus-article-mime-match-handle-first (condition)
+ (if condition
+ (let ((alist gnus-article-mime-handle-alist) ihandle n)
+ (while (setq ihandle (pop alist))
+ (if (and (cond
+ ((functionp condition)
+ (funcall condition (cdr ihandle)))
+ ((eq condition 'undisplayed)
+ (not (or (mm-handle-undisplayer (cdr ihandle))
+ (equal (mm-handle-media-type (cdr ihandle))
+ "multipart/alternative"))))
+ ((eq condition 'undisplayed-alternative)
+ (not (mm-handle-undisplayer (cdr ihandle))))
+ (t t))
+ (gnus-article-goto-part (car ihandle))
+ (or (not n) (< (car ihandle) n)))
+ (setq n (car ihandle))))
+ (or n 1))
+ 1))
+
+(defun gnus-article-view-part (&optional n)
"View MIME part N, which is the numerical prefix."
- (interactive "p")
+ (interactive "P")
(save-current-buffer
(set-buffer gnus-article-buffer)
+ (or (numberp n) (setq n (gnus-article-mime-match-handle-first
+ gnus-article-mime-match-handle-function)))
(when (> n (length gnus-article-mime-handle-alist))
(error "No such part"))
(let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
(when (eq (gnus-mm-display-part handle) 'internal)
(gnus-set-window-start)))))))
+(defsubst gnus-article-mime-total-parts ()
+ (if (bufferp (car gnus-article-mime-handles))
+ 1 ;; single part
+ (1- (length gnus-article-mime-handles))))
+
(defun gnus-mm-display-part (handle)
"Display HANDLE and fix MIME button."
(let ((id (get-text-property (point) 'gnus-part))
(narrow-to-region (point) (point-max))
(gnus-treat-article
nil id
- (1- (length gnus-article-mime-handles))
- (car (mm-handle-type handle))))))
+ (gnus-article-mime-total-parts)
+ (mm-handle-media-type handle)))))
(select-window window))))
(goto-char point)
(delete-region (gnus-point-at-bol) (progn (forward-line 1) (point)))
(mail-content-type-get (mm-handle-disposition handle)
'filename)
""))
- (gnus-tmp-type (car (mm-handle-type handle)))
+ (gnus-tmp-type (mm-handle-media-type handle))
(gnus-tmp-description
(mail-decode-encoded-word-string (or (mm-handle-description handle)
"")))
article-type annotation
gnus-data ,handle))
(setq e (point))
- (widget-convert-button 'link b e
- :mime-handle handle
- :action 'gnus-widget-press-button
- :button-keymap gnus-mime-button-map
- :help-echo
- (lambda (widget)
- ;; Needed to properly clear the message
- ;; due to a bug in wid-edit
- (setq help-echo-owns-message t)
- (format
- "Click to %s the MIME part; %s for more options"
- (if (mm-handle-displayed-p
- (widget-get widget :mime-handle))
- "hide" "show")
- (if gnus-xemacs "button3" "mouse-3"))))))
+ (widget-convert-button
+ 'link b e
+ :mime-handle handle
+ :action 'gnus-widget-press-button
+ :button-keymap gnus-mime-button-map
+ :help-echo
+ (lambda (widget/window &optional overlay pos)
+ ;; Needed to properly clear the message due to a bug in
+ ;; wid-edit (XEmacs only).
+ (if (boundp 'help-echo-owns-message)
+ (setq help-echo-owns-message t))
+ (format
+ "%S: %s the MIME part; %S: more options"
+ (aref gnus-mouse-2 0)
+ ;; XEmacs will get a single widget arg; Emacs 21 will get
+ ;; window, overlay, position.
+ (if (mm-handle-displayed-p
+ (if overlay
+ (with-current-buffer (gnus-overlay-buffer overlay)
+ (widget-get (widget-at (gnus-overlay-start overlay))
+ :mime-handle))
+ (widget-get widget/window :mime-handle)))
+ "hide" "show")
+ (aref gnus-down-mouse-3 0))))))
(defun gnus-widget-press-button (elems el)
(goto-char (widget-get elems :from))
;; Top-level call; we clean up.
(when gnus-article-mime-handles
(mm-destroy-parts gnus-article-mime-handles)
- (setq gnus-article-mime-handle-alist nil)) ;; A trick.
+ (setq gnus-article-mime-handle-alist nil));; A trick.
(setq gnus-article-mime-handles handles)
;; We allow users to glean info from the handles.
(when gnus-article-mime-part-function
(narrow-to-region (point) (point-max))
(gnus-treat-article nil 1 1)
(widen)))
- (if (not ihandles)
- ;; Highlight the headers.
- (save-excursion
- (save-restriction
- (article-goto-body)
- (narrow-to-region (point-min) (point))
- (gnus-treat-article 'head))))))))
+ (unless ihandles
+ ;; Highlight the headers.
+ (save-excursion
+ (save-restriction
+ (article-goto-body)
+ (narrow-to-region (point-min) (point))
+ (gnus-treat-article 'head))))))))
(defvar gnus-mime-display-multipart-as-mixed nil)
(mapcar 'gnus-mime-display-part handles))
(defun gnus-mime-display-single (handle)
- (let ((type (car (mm-handle-type handle)))
+ (let ((type (mm-handle-media-type handle))
(ignored gnus-ignored-mime-types)
(not-attachment t)
(move nil)
(when (string-match (pop ignored) type)
(throw 'ignored nil)))
(if (and (setq not-attachment
- (or (not (mm-handle-disposition handle))
- (equal (car (mm-handle-disposition handle))
- "inline")
- (mm-attachment-override-p type)))
- (mm-automatic-display-p type)
- (or (mm-inlinable-part-p type)
+ (and (not (mm-inline-override-p handle))
+ (or (not (mm-handle-disposition handle))
+ (equal (car (mm-handle-disposition handle))
+ "inline")
+ (mm-attachment-override-p handle))))
+ (mm-automatic-display-p handle)
+ (or (mm-inlined-p handle)
(mm-automatic-external-display-p type)))
(setq display t)
- (when (equal (car (split-string type "/"))
- "text")
+ (when (equal (mm-handle-media-supertype handle) "text")
(setq text t)))
- (let ((id (1+ (length gnus-article-mime-handle-alist))))
+ (let ((id (1+ (length gnus-article-mime-handle-alist)))
+ beg)
(push (cons id handle) gnus-article-mime-handle-alist)
(when (or (not display)
(not (gnus-unbuttonized-mime-type-p type)))
- (gnus-article-insert-newline)
+ ;(gnus-article-insert-newline)
(gnus-insert-mime-button
handle id (list (or display (and not-attachment text))))
(gnus-article-insert-newline)
- (gnus-article-insert-newline)
- (setq move t)))
- (let ((beg (point)))
+ ;(gnus-article-insert-newline)
+ (setq move t))
+ (setq beg (point))
(cond
(display
(when move
- (forward-line -2))
+ (forward-line -2)
+ (setq beg (point)))
(let ((mail-parse-charset gnus-newsgroup-charset)
(mail-parse-ignored-charsets
- (save-excursion (set-buffer gnus-summary-buffer)
+ (save-excursion (condition-case ()
+ (set-buffer gnus-summary-buffer)
+ (error))
gnus-newsgroup-ignored-charsets)))
(mm-display-part handle t))
(goto-char (point-max)))
((and text not-attachment)
(when move
- (forward-line -2))
+ (forward-line -2)
+ (setq beg (point)))
(gnus-article-insert-newline)
(mm-insert-inline handle (mm-get-part handle))
(goto-char (point-max))))
(save-restriction
(narrow-to-region beg (point))
(gnus-treat-article
- nil (length gnus-article-mime-handle-alist)
- (1- (length gnus-article-mime-handles))
- (car (mm-handle-type handle))))))))))
+ nil id
+ (gnus-article-mime-total-parts)
+ (mm-handle-media-type handle)))))))))
(defun gnus-unbuttonized-mime-type-p (type)
"Say whether TYPE is to be unbuttonized."
(progn
(insert (format "(%c) %-18s"
(if (equal handle preferred) ?* ? )
- (if (stringp (car handle))
- (car handle)
- (car (mm-handle-type handle)))))
+ (mm-handle-media-type handle)))
(point))
`(gnus-callback
(lambda (handles)
(mail-parse-ignored-charsets
(save-excursion (set-buffer gnus-summary-buffer)
gnus-newsgroup-ignored-charsets)))
- (mm-display-part preferred)))
+ (mm-display-part preferred)
+ ;; Do highlighting.
+ (save-excursion
+ (save-restriction
+ (narrow-to-region (car begend) (point-max))
+ (gnus-treat-article
+ nil (length gnus-article-mime-handle-alist)
+ (gnus-article-mime-total-parts)
+ (mm-handle-media-type handle))))))
(goto-char (point-max))
(setcdr begend (point-marker)))))
(when ibegend
(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"
+ (format "%c%c%c%c%c%c%c"
(if cite ?c ? )
(if (or headers boring) ?h ? )
(if (or pgp pem) ?p ? )
(if signature ?s ? )
(if overstrike ?o ? )
+ (if gnus-show-mime ?m ? )
(if emphasis ?e ? )))))
-(fset 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers)
+(defalias 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers)
(defun gnus-article-maybe-hide-headers ()
"Hide unwanted headers if `gnus-have-all-headers' is nil.
;; save it to file.
(goto-char (point-max))
(insert "\n")
- (append-to-file (point-min) (point-max) file-name)
+ (write-region-as-binary (point-min) (point-max) file-name 'append)
t)))
(defun gnus-narrow-to-page (&optional arg)
If end of article, return non-nil. Otherwise return nil.
Argument LINES specifies lines to be scrolled up."
(interactive "p")
- (move-to-window-line -1)
- (if (save-excursion
- (end-of-line)
- (and (pos-visible-in-window-p) ;Not continuation line.
- (eobp)))
- ;; Nothing in this page.
- (if (or (not gnus-page-broken)
- (save-excursion
- (save-restriction
- (widen) (forward-line 1) (eobp)))) ;Real end-of-buffer?
- t ;Nothing more.
- (gnus-narrow-to-page 1) ;Go to next page.
- nil)
- ;; More in this page.
- (let ((scroll-in-place nil))
- (condition-case ()
- (scroll-up lines)
- (end-of-buffer
- ;; Long lines may cause an end-of-buffer error.
- (goto-char (point-max)))))
- (move-to-window-line 0)
- nil))
+ (let ((start (window-start))
+ end-of-buffer end-of-page)
+ (save-excursion
+ (move-to-window-line -1)
+ (if (<= (point) start)
+ (progn
+ (forward-line 2)
+ (setq start (point)))
+ (forward-line 1)
+ (setq start nil))
+ (unless (or (cond ((eq (1+ (buffer-size)) (point))
+ (and (pos-visible-in-window-p)
+ (setq end-of-buffer t)))
+ ((eobp)
+ (setq end-of-page t)))
+ (not lines))
+ (move-to-window-line lines)
+ (unless (search-backward "\n\n" nil t)
+ (setq start (point)))))
+ (cond (end-of-buffer t)
+ (end-of-page
+ (gnus-narrow-to-page 1)
+ nil)
+ (t
+ (if start
+ (set-window-start (selected-window) start)
+ (let (window-pixel-scroll-increment)
+ (scroll-up lines)))
+ nil))))
(defun gnus-article-prev-page (&optional lines)
"Show previous page of current article.
Argument LINES specifies lines to be scrolled down."
(interactive "p")
- (move-to-window-line 0)
- (if (and gnus-page-broken
- (bobp)
- (not (save-restriction (widen) (bobp)))) ;Real beginning-of-buffer?
- (progn
- (gnus-narrow-to-page -1) ;Go to previous page.
- (goto-char (point-max))
- (recenter -1))
- (let ((scroll-in-place nil))
- (prog1
- (condition-case ()
- (scroll-down lines)
- (beginning-of-buffer
- (goto-char (point-min))))
- (move-to-window-line 0)))))
+ (let (beginning-of-buffer beginning-of-page)
+ (save-excursion
+ (move-to-window-line 0)
+ (cond ((eq 1 (point))
+ (setq beginning-of-buffer t))
+ ((bobp)
+ (setq beginning-of-page t))))
+ (cond (beginning-of-buffer)
+ (beginning-of-page
+ (gnus-narrow-to-page -1))
+ (t
+ (condition-case nil
+ (let (window-pixel-scroll-increment)
+ (scroll-down lines))
+ (beginning-of-buffer
+ (goto-char (point-min))))))))
(defun gnus-article-refer-article ()
"Read article specified by message-id around point."
(defun gnus-article-check-buffer ()
"Beep if not in an article buffer."
- (unless (equal major-mode 'gnus-article-mode)
+ (unless (eq (get-buffer gnus-article-buffer) (current-buffer))
(error "Command invoked outside of a Gnus article buffer")))
(defun gnus-article-read-summary-keys (&optional arg key not-restore-window)
(gnus-article-check-buffer)
(let ((nosaves
'("q" "Q" "c" "r" "R" "\C-c\C-f" "m" "a" "f" "F"
- "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"
+ "Zc" "ZC" "ZE" "ZJ" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"
"=" "^" "\M-^" "|"))
(nosave-but-article
'("A\r"))
(set-buffer gnus-article-current-summary)
(let (gnus-pick-mode)
(push (or key last-command-event) unread-command-events)
- (setq keys (if gnus-xemacs
+ (setq keys (static-if (featurep 'xemacs)
(events-to-keys (read-key-sequence nil))
(read-key-sequence nil)))))
-
(message "")
(if (or (member keys nosaves)
;; We disable the pick minor mode commands.
(let (gnus-pick-mode)
(setq func (lookup-key (current-local-map) keys))))
- (if (not func)
+ (if (or (not func)
+ (numberp func))
(ding)
(unless (member keys nosave-in-article)
(set-buffer gnus-article-current-summary))
If given a prefix, show the hidden text instead."
(interactive (append (gnus-article-hidden-arg) (list 'force)))
(gnus-article-hide-headers arg)
+ (gnus-article-hide-list-identifiers arg)
(gnus-article-hide-pgp arg)
(gnus-article-hide-citation-maybe arg force)
(gnus-article-hide-signature arg))
;; We only request an article by message-id when we do not have the
;; headers for it, so we'll have to get those.
(when (stringp article)
- (let ((gnus-override-method gnus-refer-article-method))
- (gnus-read-header article)))
+ (gnus-read-header article))
;; If the article number is negative, that means that this article
;; doesn't belong in this newsgroup (possibly), so we find its
;; This is a sparse gap article.
(setq do-update-line article)
(setq article (mail-header-id header))
- (let ((gnus-override-method gnus-refer-article-method))
- (setq sparse-header (gnus-read-header article)))
+ (setq sparse-header (gnus-read-header article))
(setq gnus-newsgroup-sparse
(delq article gnus-newsgroup-sparse)))
((vectorp header)
gnus-newsgroup-name)))
(when (and (eq (car method) 'nneething)
(vectorp header))
- (let ((dir (concat
+ (let ((dir (expand-file-name
+ (mail-header-subject header)
(file-name-as-directory
(or (cadr (assq 'nneething-address method))
- (nth 1 method)))
- (mail-header-subject header))))
+ (nth 1 method))))))
(when (file-directory-p dir)
(setq article 'nneething)
(gnus-group-enter-directory dir))))))))
(assq article gnus-newsgroup-reads)))
gnus-canceled-mark))
nil)
- ;; We first check `gnus-original-article-buffer'.
- ((and (get-buffer gnus-original-article-buffer)
- (numberp article)
- (save-excursion
- (set-buffer gnus-original-article-buffer)
- (and (equal (car gnus-original-article) group)
- (eq (cdr gnus-original-article) article))))
- (insert-buffer-substring gnus-original-article-buffer)
- 'article)
;; Check the backlog.
((and gnus-keep-backlog
(gnus-backlog-request-article group article (current-buffer)))
(gnus-cache-request-article article group))
'article)
;; Get the article and put into the article buffer.
- ((or (stringp article) (numberp article))
- (let ((gnus-override-method
- (and (stringp article) gnus-refer-article-method))
+ ((or (stringp article)
+ (numberp article))
+ (let ((gnus-override-method gnus-override-method)
+ (methods (and (stringp article)
+ gnus-refer-article-method))
+ result
(buffer-read-only nil))
- (erase-buffer)
- (gnus-kill-all-overlays)
- (gnus-check-group-server)
- (when (gnus-request-article article group (current-buffer))
- (when (numberp article)
- (gnus-async-prefetch-next group article gnus-summary-buffer)
- (when gnus-keep-backlog
- (gnus-backlog-enter-article
- group article (current-buffer))))
- 'article)))
+ (if (or (not (listp methods))
+ (and (symbolp (car methods))
+ (assq (car methods) nnoo-definition-alist)))
+ (setq methods (list methods)))
+ (when (and (null gnus-override-method)
+ methods)
+ (setq gnus-override-method (pop methods)))
+ (while (not result)
+ (when (eq gnus-override-method 'current)
+ (setq gnus-override-method gnus-current-select-method))
+ (erase-buffer)
+ (gnus-kill-all-overlays)
+ (let ((gnus-newsgroup-name group))
+ (gnus-check-group-server))
+ (when (gnus-request-article article group (current-buffer))
+ (when (numberp article)
+ (gnus-async-prefetch-next group article
+ gnus-summary-buffer)
+ (when gnus-keep-backlog
+ (gnus-backlog-enter-article
+ group article (current-buffer))))
+ (setq result 'article))
+ (if (not result)
+ (if methods
+ (setq gnus-override-method (pop methods))
+ (setq result 'done))))
+ (and (eq result 'article) 'article)))
;; It was a pseudo.
(t article)))
(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))
:group 'gnus-article-various
:type 'hook)
+(defcustom gnus-article-edit-article-setup-function
+ 'gnus-article-mime-edit-article-setup
+ "Function called to setup an editing article buffer."
+ :group 'gnus-article-various
+ :type 'function)
+
(defvar gnus-article-edit-done-function nil)
(defvar gnus-article-edit-mode-map nil)
(set-buffer gnus-article-buffer)
(gnus-article-edit-mode)
(funcall start-func)
- ;;(gnus-article-delete-text-of-type 'annotation)
- ;;(gnus-set-text-properties (point-min) (point-max) nil)
(gnus-configure-windows 'edit-article)
(setq gnus-article-edit-done-function exit-func)
(setq gnus-prev-winconf winconf)
+ (when gnus-article-edit-article-setup-function
+ (funcall gnus-article-edit-article-setup-function))
(gnus-message 6 "C-c C-c to end edits")))
(defun gnus-article-edit-done (&optional arg)
(let ((func gnus-article-edit-done-function)
(buf (current-buffer))
(start (window-start)))
+ (remove-hook 'gnus-article-mode-hook
+ 'gnus-article-mime-edit-article-unwind)
(gnus-article-edit-exit)
(save-excursion
(set-buffer buf)
"Exit the article editing without updating."
(interactive)
;; We remove all text props from the article buffer.
- (let ((buf (format "%s" (buffer-string)))
+ (let ((buf (buffer-substring-no-properties (point-min) (point-max)))
(curbuf (current-buffer))
(p (point))
(window-start (window-start)))
(query-replace-regexp "\\([.!?][])}]* \\)\\([[({A-Z]\\)" "\\1 \\2"))))
;;;
+;;; Article editing with MIME-Edit
+;;;
+
+(defcustom gnus-article-mime-edit-article-setup-hook nil
+ "Hook run after setting up a MIME editing article buffer."
+ :group 'gnus-article-various
+ :type 'hook)
+
+(defun gnus-article-mime-edit-article-unwind ()
+ "Unwind `gnus-article-buffer' if article editing was given up."
+ (remove-hook 'gnus-article-mode-hook 'gnus-article-mime-edit-article-unwind)
+ (when mime-edit-mode-flag
+ (mime-edit-exit 'nomime 'no-error)
+ (message ""))
+ (when (featurep 'font-lock)
+ (setq font-lock-defaults nil)
+ (font-lock-mode 0)))
+
+(defun gnus-article-mime-edit-article-setup ()
+ "Convert current buffer to MIME-Edit buffer and turn on MIME-Edit mode
+after replacing with the original article."
+ (setq gnus-show-mime t)
+ (setq gnus-article-edit-done-function
+ `(lambda (&rest args)
+ (when mime-edit-mode-flag
+ (mime-edit-exit)
+ (message ""))
+ (goto-char (point-min))
+ (let (case-fold-search)
+ (when (re-search-forward
+ (format "^%s$" (regexp-quote mail-header-separator))
+ nil t)
+ (replace-match "")))
+ (when (featurep 'font-lock)
+ (setq font-lock-defaults nil)
+ (font-lock-mode 0))
+ (apply ,gnus-article-edit-done-function args)
+ (set-buffer gnus-original-article-buffer)
+ (erase-buffer)
+ (insert-buffer gnus-article-buffer)
+ (setq gnus-current-headers (gnus-article-make-full-mail-header))
+ (gnus-article-prepare-display)))
+ (substitute-key-definition
+ 'gnus-article-edit-exit 'gnus-article-mime-edit-exit
+ gnus-article-edit-mode-map)
+ (erase-buffer)
+ (insert-buffer gnus-original-article-buffer)
+ (mime-edit-again)
+ (when (featurep 'font-lock)
+ (set (make-local-variable 'font-lock-defaults)
+ '(message-font-lock-keywords t))
+ (font-lock-set-defaults)
+ (turn-on-font-lock))
+ (add-hook 'gnus-article-mode-hook 'gnus-article-mime-edit-article-unwind)
+ (gnus-run-hooks 'gnus-article-mime-edit-article-setup-hook))
+
+(defun gnus-article-mime-edit-exit ()
+ "Exit the article MIME editing without updating."
+ (interactive)
+ (let ((winconf gnus-prev-winconf)
+ buf)
+ (when mime-edit-mode-flag
+ (mime-edit-exit)
+ (message ""))
+ (goto-char (point-min))
+ (let (case-fold-search)
+ (when (re-search-forward
+ (format "^%s$" (regexp-quote mail-header-separator)) nil t)
+ (replace-match "")))
+ (when (featurep 'font-lock)
+ (setq font-lock-defaults nil)
+ (font-lock-mode 0))
+ ;; We remove all text props from the article buffer.
+ (setq buf (format "%s" (buffer-string)))
+ (set-buffer (get-buffer-create gnus-original-article-buffer))
+ (erase-buffer)
+ (insert buf)
+ (setq gnus-current-headers (gnus-article-make-full-mail-header))
+ (gnus-article-prepare-display)
+ (set-window-configuration winconf)))
+
+;;;
;;; Article highlights
;;;
;;; Internal Variables:
-(defcustom gnus-button-url-regexp "\\b\\(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\\):\\)\\(//[-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)
("mailto:\\([-a-zA-Z.@_+0-9%]+\\)" 0 t gnus-url-mailto 1)
("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1)
;; This is how URLs _should_ be embedded in text...
- ("<URL: *\\([^>]*\\)>" 0 t gnus-button-embedded-url 1)
+ ("<URL: *\\([^<>]*\\)>" 0 t gnus-button-embedded-url 1)
;; Raw URLs.
- (,gnus-button-url-regexp 0 t gnus-button-url 0))
+ (,gnus-button-url-regexp 0 t browse-url 0))
"*Alist of regexps matching buttons in article bodies.
Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where
("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 t gnus-button-reply 1)
("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+"
0 t gnus-button-mailto 0)
- ("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t gnus-button-url 0)
- ("^Subject:" ,gnus-button-url-regexp 0 t gnus-button-url 0)
- ("^[^:]+:" ,gnus-button-url-regexp 0 t gnus-button-url 0)
+ ("^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)
("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t
gnus-button-message-id 3))
"*Alist of headers and regexps to match buttons in article heads.
(when fun
(funcall fun data))))
+(defun gnus-article-prev-button (n)
+ "Move point to N buttons backward.
+If N is negative, move forward instead."
+ (interactive "p")
+ (gnus-article-next-button (- n)))
+
+(defun gnus-article-next-button (n)
+ "Move point to N buttons forward.
+If N is negative, move backward instead."
+ (interactive "p")
+ (let ((function (if (< n 0) 'previous-single-property-change
+ 'next-single-property-change))
+ (inhibit-point-motion-hooks t)
+ (backward (< n 0))
+ (limit (if (< n 0) (point-min) (point-max))))
+ (setq n (abs n))
+ (while (and (not (= limit (point)))
+ (> n 0))
+ ;; Skip past the current button.
+ (when (get-text-property (point) 'gnus-callback)
+ (goto-char (funcall function (point) 'gnus-callback nil limit)))
+ ;; Go to the next (or previous) button.
+ (gnus-goto-char (funcall function (point) 'gnus-callback nil limit))
+ ;; Put point at the start of the button.
+ (when (and backward (not (get-text-property (point) 'gnus-callback)))
+ (goto-char (funcall function (point) 'gnus-callback nil limit)))
+ ;; Skip past intangible buttons.
+ (when (get-text-property (point) 'intangible)
+ (incf n))
+ (decf n))
+ (unless (zerop n)
+ (gnus-message 5 "No more buttons"))
+ n))
+
(defun gnus-article-highlight (&optional force)
"Highlight current article.
This function calls `gnus-article-highlight-headers',
It does this by highlighting everything after
`gnus-signature-separator' using `gnus-signature-face'."
(interactive)
+ (when gnus-signature-face
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (let ((buffer-read-only nil)
+ (inhibit-point-motion-hooks t))
+ (save-restriction
+ (when (gnus-article-narrow-to-signature)
+ (gnus-overlay-put (gnus-make-overlay (point-min) (point-max))
+ 'face gnus-signature-face)))))))
+
+(defun gnus-article-buttonize-signature ()
+ "Add button to the signature."
+ (interactive)
(save-excursion
(set-buffer gnus-article-buffer)
(let ((buffer-read-only nil)
(inhibit-point-motion-hooks t))
- (save-restriction
- (when (and gnus-signature-face
- (gnus-article-narrow-to-signature))
- (gnus-overlay-put (gnus-make-overlay (point-min) (point-max))
- 'face gnus-signature-face)
- (widen)
- (gnus-article-search-signature)
- (let ((start (match-beginning 0))
- (end (set-marker (make-marker) (1+ (match-end 0)))))
- (gnus-article-add-button start (1- end) 'gnus-signature-toggle
- end)))))))
+ (when (gnus-article-search-signature)
+ (gnus-article-add-button (match-beginning 0) (match-end 0)
+ 'gnus-signature-toggle
+ (set-marker (make-marker)
+ (1+ (match-end 0))))))))
(defun gnus-button-in-region-p (b e prop)
"Say whether PROP exists in the region."
(alist gnus-button-alist)
beg entry regexp)
;; Remove all old markers.
- (let (marker entry)
+ (let (marker entry new-list)
(while (setq marker (pop gnus-button-marker-list))
- (goto-char marker)
- (when (setq entry (gnus-button-entry))
- (put-text-property (match-beginning (nth 1 entry))
- (match-end (nth 1 entry))
- 'gnus-callback nil))
- (set-marker marker nil)))
+ (if (or (< marker (point-min)) (>= marker (point-max)))
+ (push marker new-list)
+ (goto-char marker)
+ (when (setq entry (gnus-button-entry))
+ (put-text-property (match-beginning (nth 1 entry))
+ (match-end (nth 1 entry))
+ 'gnus-callback nil))
+ (set-marker marker nil)))
+ (setq gnus-button-marker-list new-list))
;; We skip the headers.
(article-goto-body)
(setq beg (point))
(list 'gnus-callback fun)
(and data (list 'gnus-data data))))
(widget-convert-button 'link from to :action 'gnus-widget-press-button
- :button-keymap gnus-widget-button-keymap))
+ ;; Quote `:button-keymap' for Mule 2.3
+ ;; but it won't work.
+ ':button-keymap gnus-widget-button-keymap))
;;; Internal functions:
(save-excursion
(set-buffer gnus-article-buffer)
(let ((buffer-read-only nil)
- (inhibit-point-motion-hooks t))
+ (inhibit-point-motion-hooks t)
+ (limit (next-single-property-change end 'mime-view-entity
+ nil (point-max))))
(if (get-text-property end 'invisible)
- (gnus-article-unhide-text end (point-max))
- (gnus-article-hide-text end (point-max) gnus-hidden-properties)))))
+ (gnus-article-unhide-text end limit)
+ (gnus-article-hide-text end limit gnus-hidden-properties)))))
(defun gnus-button-entry ()
;; Return the first entry in `gnus-button-alist' matching this place.
(setq to (gnus-url-unhex-string url)))
(setq args (cons (list "to" to) args)
subject (cdr-safe (assoc "subject" args)))
- (message-mail)
- (while args
- (setq func (intern-soft (concat "message-goto-" (downcase (caar args)))))
- (if (fboundp func)
- (funcall func)
- (message-position-on-field (caar args)))
- (insert (mapconcat 'identity (cdar args) ", "))
- (setq args (cdr args)))
- (if subject
- (message-goto-body)
- (message-goto-subject))))
+ (gnus-setup-message 'reply
+ (message-mail)
+ (while args
+ (setq func (intern-soft (concat "message-goto-" (downcase (caar args)))))
+ (if (fboundp func)
+ (funcall func)
+ (message-position-on-field (caar args)))
+ (insert (mapconcat 'identity (cdar args) ", "))
+ (setq args (cdr args)))
+ (if subject
+ (message-goto-body)
+ (message-goto-subject)))))
(defun gnus-button-mailto (address)
- ;; Mail to ADDRESS.
+ "Mail to ADDRESS."
(set-buffer (gnus-copy-article-buffer))
(message-reply address))
-(defun gnus-button-reply (address)
- ;; Reply to ADDRESS.
- (message-reply address))
-
-(defun gnus-button-url (address)
- "Browse ADDRESS."
- ;; In Emacs 20, `browse-url-browser-function' may be an alist.
- (if (listp browse-url-browser-function)
- (browse-url address)
- (funcall browse-url-browser-function address)))
+(defalias 'gnus-button-reply 'message-reply)
(defun gnus-button-embedded-url (address)
- "Browse ADDRESS."
- ;; In Emacs 20, `browse-url-browser-function' may be an alist.
- (if (listp browse-url-browser-function)
- (browse-url (gnus-strip-whitespace address))
- (funcall browse-url-browser-function (gnus-strip-whitespace address))))
+ "Activate ADDRESS with `browse-url'."
+ (browse-url (gnus-strip-whitespace address)))
+
+(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.
(define-key gnus-prev-page-map gnus-mouse-2 'gnus-button-prev-page)
(define-key gnus-prev-page-map "\r" 'gnus-button-prev-page))
-(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))))
+(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))))
+ )
(defvar gnus-next-page-map nil)
(unless gnus-next-page-map
- (setq gnus-next-page-map (make-keymap))
- (suppress-keymap gnus-prev-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))
(gnus-article-prev-page)
(select-window win)))
-(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))))
+(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
+ gnus-callback gnus-article-button-next-page
+ article-type annotation
+ mime-view-situation ,situation))))
+ )
(defun gnus-article-button-next-page (arg)
"Go to the next page."
'(mail-decode-encoded-word-region)
"List of methods used to decode headers.
-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
+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
whose names match REGEXP.
(eq gnus-newsgroup-name
(car gnus-decode-header-methods-cache)))
(setq gnus-decode-header-methods-cache (list gnus-newsgroup-name))
- (mapc '(lambda (x)
- (if (symbolp x)
- (nconc gnus-decode-header-methods-cache (list x))
- (if (and gnus-newsgroup-name
- (string-match (car x) gnus-newsgroup-name))
- (nconc gnus-decode-header-methods-cache
- (list (cdr x))))))
+ (mapcar (lambda (x)
+ (if (symbolp x)
+ (nconc gnus-decode-header-methods-cache (list x))
+ (if (and gnus-newsgroup-name
+ (string-match (car x) gnus-newsgroup-name))
+ (nconc gnus-decode-header-methods-cache
+ (list (cdr x))))))
gnus-decode-header-methods))
(let ((xlist gnus-decode-header-methods-cache))
(pop xlist)
(when (string-match (pop list) type)
(throw 'found t)))))))
(highlightp (gnus-visual-p 'article-highlight 'highlight))
- val elem)
+ (entity (static-unless (featurep 'xemacs)
+ (when (eq 'head condition)
+ (get-text-property (point-min) 'mime-view-entity))))
+ val elem buttonized)
(gnus-run-hooks 'gnus-part-display-hook)
- (while (setq elem (pop alist))
- (setq val (symbol-value (car elem)))
- (when (and (or (consp val)
- treated-type)
- (gnus-treat-predicate val)
- (or (not (get (car elem) 'highlight))
- highlightp))
- (save-restriction
- (funcall (cadr elem)))))))
+ (unless gnus-inhibit-treatment
+ (while (setq elem (pop alist))
+ (setq val
+ (save-excursion
+ (if (gnus-buffer-live-p gnus-summary-buffer)
+ (set-buffer gnus-summary-buffer))
+ (symbol-value (car elem))))
+ (when (and (or (consp val)
+ treated-type)
+ (gnus-treat-predicate val)
+ (or (not (get (car elem) 'highlight))
+ highlightp))
+ (when (and (not buttonized)
+ (memq (car elem)
+ '(gnus-treat-hide-signature
+ gnus-treat-highlight-signature)))
+ (gnus-article-buttonize-signature)
+ (setq buttonized t))
+ (save-restriction
+ (funcall (cadr elem)))))
+ ;; FSF Emacsen does not inherit the existing text properties
+ ;; in the new text, so we should do it for `mime-view-entity'.
+ (static-unless (featurep 'xemacs)
+ (when entity
+ (put-text-property (point-min) (point-max)
+ 'mime-view-entity entity))))))
;; Dynamic variables.
-(defvar part-number)
-(defvar total-parts)
-(defvar type)
-(defvar condition)
-(defvar length)
+(eval-when-compile
+ (defvar part-number)
+ (defvar total-parts)
+ (defvar type)
+ (defvar condition)
+ (defvar length))
+
(defun gnus-treat-predicate (val)
(cond
- (condition
- (eq condition val))
((null val)
nil)
- ((eq val t)
- t)
- ((eq val 'head)
- nil)
- ((eq val 'last)
- (eq part-number total-parts))
- ((numberp val)
- (< length val))
((and (listp val)
(stringp (car val)))
(apply 'gnus-or (mapcar `(lambda (s)
((eq pred 'or)
(apply 'gnus-or (mapcar 'gnus-treat-predicate val)))
((eq pred 'and)
- (apply 'gnus-and (mapcar 'gnus-tread-predicate val)))
+ (apply 'gnus-and (mapcar 'gnus-treat-predicate val)))
((eq pred 'not)
- (not (gnus-treat-predicate val)))
+ (not (gnus-treat-predicate (car val))))
((eq pred 'typep)
- (equal (cadr val) type))
+ (equal (car val) type))
(t
(error "%S is not a valid predicate" pred)))))
+ ((eq val 'mime)
+ gnus-show-mime)
+ (condition
+ (eq condition val))
+ ((eq val t)
+ t)
+ ((eq val 'head)
+ nil)
+ ((eq val 'last)
+ (eq part-number total-parts))
+ ((numberp val)
+ (< length val))
(t
(error "%S is not a valid value" val))))
+
+;;; @ for mime-view
+;;;
+
+(defun gnus-article-header-presentation-method (entity situation)
+ (mime-insert-header entity)
+ )
+
+(set-alist 'mime-header-presentation-method-alist
+ 'gnus-original-article-mode
+ #'gnus-article-header-presentation-method)
+
+(defun gnus-mime-preview-quitting-method ()
+ (mime-preview-kill-buffer)
+ (delete-other-windows)
+ (gnus-article-show-summary)
+ (gnus-summary-select-article gnus-show-all-headers t))
+
+(set-alist 'mime-preview-quitting-method-alist
+ 'gnus-original-article-mode #'gnus-mime-preview-quitting-method)
+
+(set-alist 'mime-preview-following-method-alist
+ 'gnus-original-article-mode #'gnus-following-method)
+
+(set-alist 'mime-preview-over-to-previous-method-alist
+ 'gnus-original-article-mode
+ (lambda ()
+ (if (> (point-min) 1)
+ (gnus-article-prev-page)
+ (gnus-article-read-summary-keys
+ nil (gnus-character-to-event ?P)))))
+
+(set-alist 'mime-preview-over-to-next-method-alist
+ 'gnus-original-article-mode'
+ (lambda ()
+ (if (< (point-max) (buffer-size))
+ (gnus-article-next-page)
+ (gnus-article-read-summary-keys
+ nil (gnus-character-to-event ?N)))))
+
+
+;;; @ end
+;;;
+
(gnus-ems-redefine)
(provide 'gnus-art)
projects / elisp / gnus.git- / blobdiff