(require 'gnus-int)
(require 'alist)
(require 'mime-view)
+(require 'wid-edit)
;; Avoid byte-compile warnings.
(eval-when-compile
(require 'mail-parse)
(require 'mm-decode)
(require 'mm-view)
- (require 'wid-edit)
(require 'mm-uu)
)
"^Precedence:" "^Original-[-A-Za-z]+:" "^X-filename:" "^X-Orcpt:"
"^Old-Received:" "^X-Pgp" "^X-Auth:" "^X-From-Line:"
"^X-Gnus-Article-Number:" "^X-Majordomo:" "^X-Url:" "^X-Sender:"
- "^MBOX-Line" "^Priority:" "^X-Pgp" "^X400-[-A-Za-z]+:"
+ "^MBOX-Line" "^Priority:" "^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:"
:group 'gnus-article-hiding)
(defcustom gnus-visible-headers
- "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^[BGF]?Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|^X-Sent:"
+ "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^[BGF]?Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Mail-Followup-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|^X-Sent:"
"*All headers that do not match this regexp will be hidden.
This variable can also be a list of regexp of headers to remain visible.
If this variable is non-nil, `gnus-ignored-headers' will be ignored."
(defcustom gnus-article-x-face-command
(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)
- (or (image-type-available-p 'xpm)
- (image-type-available-p 'xbm)))
- 'gnus-article-display-xface)
- ((and (not gnus-xemacs)
+ (image-type-available-p 'xbm))
+ (if (module-installed-p 'x-face-e21)
+ 'x-face-decode-message-header
+ 'gnus-article-display-xface))
+ ((and (not (featurep 'xemacs))
window-system
(module-installed-p 'x-face-mule))
'x-face-mule-gnus-article-display-x-face)
+ (gnus-article-compface-xbm
+ "{ echo '/* Width=48, Height=48 */'; uncompface; } | display -")
(t
- "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | display -"))
+ "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | \
+display -"))
"*String or function to be executed to display an X-Face header.
If it is a string, the command will be executed in a sub-shell
asynchronously. The compressed face will be piped to this command."
:type '(choice string
+ (function-item
+ :tag "x-face-decode-message-header (x-face-e21)"
+ x-face-decode-message-header)
(function-item gnus-article-display-xface)
(function-item x-face-mule-gnus-article-display-x-face)
function)
:type '(choice 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\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\s-\\|[-,;:\"]\\s-\\|[?!.]+\\s-\\|\\s)\\)")
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-signature)
(defface gnus-signature-face
- '((t (:italic t)))
+ '((t
+ (:italic t)))
"Face used for highlighting a signature in the article buffer."
:group 'gnus-article-highlight
:group 'gnus-article-signature)
"Function used to decode headers.")
(defvar gnus-article-dumbquotes-map
- '(("\202" ",")
+ '(("\200" "EUR")
+ ("\202" ",")
("\203" "f")
("\204" ",,")
("\205" "...")
("\223" "``")
("\224" "\"")
("\225" "*")
- ("\226" "---")
- ("\227" "-")
+ ("\226" "-")
+ ("\227" "--")
("\231" "(TM)")
("\233" ">")
("\234" "oe")
:value undisplayed-alternative)
(function)))
+(defcustom gnus-mime-action-alist
+ '(("save to file" . gnus-mime-save-part)
+ ("save and strip" . gnus-mime-save-part-and-strip)
+ ("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)
+ ("toggle display" . gnus-article-view-part-as-charset)
+ ("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
;;;
: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.
(put 'gnus-treat-overstrike 'highlight t)
(defcustom gnus-treat-display-xface
- (if (or (and gnus-xemacs (featurep 'xface))
- (eq 'x-face-mule-gnus-article-display-x-face
- gnus-article-x-face-command))
- 'head
- nil)
+ (and (or (and (fboundp 'image-type-available-p)
+ (image-type-available-p 'xbm)
+ (string-match "^0x" (shell-command-to-string "uncompface")))
+ (and (featurep 'xemacs) (featurep 'xface))
+ (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."
(put 'gnus-treat-display-xface 'highlight t)
(defcustom gnus-treat-display-smileys
- (if (or (and gnus-xemacs (featurep 'xpm))
- (and (not gnus-xemacs)
+ (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
: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-x-pgp-sig nil
+ "Verify X-PGP-Sig.
+To automatically treat X-PGP-Sig, set it to head.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
+ :group 'gnus-article-treat
+ :group 'mime-security
+ :type gnus-article-treat-custom)
+
+(defvar gnus-article-encrypt-protocol-alist
+ '(("PGP" . mml2015-self-encrypt)))
+
+;; Set to nil if more than one protocol added to
+;; gnus-article-encrypt-protocol-alist.
+(defcustom gnus-article-encrypt-protocol "PGP"
+ "The protocol used for encrypt articles.
+It is a string, such as \"PGP\". If nil, ask user."
+ :type 'string
+ :group 'mime-security)
+
;;; Internal variables
(defvar article-goto-body-goes-to-point-min-p nil)
(defvar gnus-treatment-function-alist
'((gnus-treat-decode-article-as-default-mime-charset
gnus-article-decode-article-as-default-mime-charset)
+ (gnus-treat-x-pgp-sig gnus-article-verify-x-pgp-sig)
(gnus-treat-strip-banner gnus-article-strip-banner)
(gnus-treat-strip-headers-in-body gnus-article-strip-headers-in-body)
(gnus-treat-buttonize gnus-article-add-buttons)
(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)
(defvar gnus-article-mode-syntax-table
(let ((table (copy-syntax-table text-mode-syntax-table)))
- (modify-syntax-entry ?- "w" table)
+ ;; This causes the citation match run O(2^n).
+ ;; (modify-syntax-entry ?- "w" table)
(modify-syntax-entry ?> ")" table)
(modify-syntax-entry ?< "(" table)
table)
(defsubst gnus-article-hide-text (b e props)
"Set text PROPS on the B to E region, extending `intangible' 1 past B."
- (add-text-properties b e props)
+ (gnus-add-text-properties-when 'article-type nil b e props)
(when (memq 'intangible props)
(put-text-property
(max (1- b) (point-min))
b 'intangible (cddr (memq 'intangible props)))))
+
(defsubst gnus-article-unhide-text (b e)
"Remove hidden text properties from region between B and E."
(remove-text-properties b e gnus-hidden-properties)
(narrow-to-region header-start header-end)
(article-hide-headers)
;; Re-display X-Face image under XEmacs.
- (when (and gnus-xemacs
+ (when (and (featurep 'xemacs)
(gnus-functionp gnus-article-x-face-command))
(let ((func (cadr (assq 'gnus-treat-display-xface
gnus-treatment-function-alist)))
(set-buffer gnus-summary-buffer)
(error))
gnus-newsgroup-ignored-charsets))
- ct cte ctl charset)
+ ct cte ctl charset format)
(save-excursion
(save-restriction
(article-narrow-to-head)
(prompt
(mm-read-coding-system "Charset to decode: "))
(ctl
- (mail-content-type-get ctl 'charset))))
+ (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))))
(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")))
+ (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))))
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)
- (quoted-printable-decode-region (point) (point-max) charset)))))
+ (save-restriction
+ (narrow-to-region (point) (point-max))
+ (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))
(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."
(when regexp
(goto-char (point-min))
(when (re-search-forward
- (concat "^Subject: +\\(Re: +\\)?\\(" regexp " *\\)")
+ (concat "^Subject: +\\(\\(\\(Re: +\\)?\\(" regexp
+ " *\\)\\)+\\(Re: +\\)?\\)")
nil t)
- (delete-region (match-beginning 2) (match-end 0)))))))))
+ (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."
(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))))))))))
'hidden
nil)))
-(defun gnus-article-show-hidden-text (type &optional hide)
+(defun gnus-article-show-hidden-text (type &optional dummy)
"Show all hidden text of type TYPE.
-If HIDE, hide the text instead."
- (save-excursion
- (let ((buffer-read-only nil)
- (inhibit-point-motion-hooks t)
- (end (point-min))
- beg)
- (while (setq beg (text-property-any end (point-max) 'article-type type))
- (goto-char beg)
- (setq end (or
- (text-property-not-all beg (point-max) 'article-type type)
- (point-max)))
- (if hide
- (gnus-article-hide-text beg end gnus-hidden-properties)
- (gnus-article-unhide-text beg end))
- (goto-char end))
- t)))
+Originally it is hide instead of DUMMY."
+ (let ((buffer-read-only nil)
+ (inhibit-point-motion-hooks t))
+ (gnus-remove-text-properties-when
+ 'article-type type
+ (point-min) (point-max)
+ (cons 'article-type (cons type
+ gnus-hidden-properties)))))
(defconst article-time-units
`((year . ,(* 365.25 24 60 60))
(let ((default-name
(funcall function group headers (symbol-value variable)))
result)
- (setq
- result
- (cond
- ((eq filename 'default)
- default-name)
- ((eq filename t)
- default-name)
- (filename filename)
- (t
- (let* ((split-name (gnus-get-split-value gnus-split-methods))
- (prompt
- (format prompt
- (if (and gnus-number-of-articles-to-be-saved
- (> gnus-number-of-articles-to-be-saved 1))
- (format "these %d articles"
- gnus-number-of-articles-to-be-saved)
- "this article")))
- (file
- ;; Let the split methods have their say.
- (cond
- ;; No split name was found.
- ((null split-name)
- (read-file-name
- (concat prompt " (default "
- (file-name-nondirectory default-name) ") ")
- (file-name-directory default-name)
- default-name))
- ;; A single group name is returned.
- ((stringp split-name)
- (setq default-name
- (funcall function split-name headers
- (symbol-value variable)))
- (read-file-name
- (concat prompt " (default "
- (file-name-nondirectory default-name) ") ")
- (file-name-directory default-name)
- default-name))
- ;; A single split name was found
- ((= 1 (length split-name))
- (let* ((name (expand-file-name
- (car split-name) gnus-article-save-directory))
- (dir (cond ((file-directory-p name)
- (file-name-as-directory name))
- ((file-exists-p name) name)
- (t gnus-article-save-directory))))
- (read-file-name
- (concat prompt " (default " name ") ")
- dir name)))
- ;; A list of splits was found.
- (t
- (setq split-name (nreverse split-name))
- (let (result)
- (let ((file-name-history
- (nconc split-name file-name-history)))
- (setq result
- (expand-file-name
- (read-file-name
- (concat prompt " (`M-p' for defaults) ")
- gnus-article-save-directory
- (car split-name))
- gnus-article-save-directory)))
- (car (push result file-name-history)))))))
- ;; Create the directory.
- (gnus-make-directory (file-name-directory file))
- ;; If we have read a directory, we append the default file name.
- (when (file-directory-p file)
- (setq file (concat (file-name-as-directory file)
- (file-name-nondirectory default-name))))
- ;; Possibly translate some characters.
- (nnheader-translate-file-chars file)))))
+ (setq result
+ (expand-file-name
+ (cond
+ ((eq filename 'default)
+ default-name)
+ ((eq filename t)
+ default-name)
+ (filename filename)
+ (t
+ (let* ((split-name (gnus-get-split-value gnus-split-methods))
+ (prompt
+ (format prompt
+ (if (and gnus-number-of-articles-to-be-saved
+ (> gnus-number-of-articles-to-be-saved 1))
+ (format "these %d articles"
+ gnus-number-of-articles-to-be-saved)
+ "this article")))
+ (file
+ ;; Let the split methods have their say.
+ (cond
+ ;; No split name was found.
+ ((null split-name)
+ (read-file-name
+ (concat prompt " (default "
+ (file-name-nondirectory default-name) ") ")
+ (file-name-directory default-name)
+ default-name))
+ ;; A single group name is returned.
+ ((stringp split-name)
+ (setq default-name
+ (funcall function split-name headers
+ (symbol-value variable)))
+ (read-file-name
+ (concat prompt " (default "
+ (file-name-nondirectory default-name) ") ")
+ (file-name-directory default-name)
+ default-name))
+ ;; A single split name was found
+ ((= 1 (length split-name))
+ (let* ((name (expand-file-name
+ (car split-name)
+ gnus-article-save-directory))
+ (dir (cond ((file-directory-p name)
+ (file-name-as-directory name))
+ ((file-exists-p name) name)
+ (t gnus-article-save-directory))))
+ (read-file-name
+ (concat prompt " (default " name ") ")
+ dir name)))
+ ;; A list of splits was found.
+ (t
+ (setq split-name (nreverse split-name))
+ (let (result)
+ (let ((file-name-history
+ (nconc split-name file-name-history)))
+ (setq result
+ (expand-file-name
+ (read-file-name
+ (concat prompt " (`M-p' for defaults) ")
+ gnus-article-save-directory
+ (car split-name))
+ gnus-article-save-directory)))
+ (car (push result file-name-history)))))))
+ ;; Create the directory.
+ (gnus-make-directory (file-name-directory file))
+ ;; If we have read a directory, we append the default file name.
+ (when (file-directory-p file)
+ (setq file (expand-file-name (file-name-nondirectory
+ default-name)
+ (file-name-as-directory file))))
+ ;; Possibly translate some characters.
+ (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)))
+(defun article-verify-x-pgp-sig ()
+ "Verify X-PGP-Sig."
+ (interactive)
+ (if (gnus-buffer-live-p gnus-original-article-buffer)
+ (let ((sig (with-current-buffer gnus-original-article-buffer
+ (gnus-fetch-field "X-PGP-Sig")))
+ items info headers)
+ (when (and sig
+ mml2015-use
+ (mml2015-clear-verify-function))
+ (with-temp-buffer
+ (insert-buffer gnus-original-article-buffer)
+ (setq items (split-string sig))
+ (message-narrow-to-head)
+ (let ((inhibit-point-motion-hooks t)
+ (case-fold-search t))
+ ;; Don't verify multiple headers.
+ (setq headers (mapconcat (lambda (header)
+ (concat header ": "
+ (mail-fetch-field header) "\n"))
+ (split-string (nth 1 items) ",") "")))
+ (delete-region (point-min) (point-max))
+ (insert "-----BEGIN PGP SIGNED MESSAGE-----\n\n")
+ (insert "X-Signed-Headers: " (nth 1 items) "\n")
+ (insert headers)
+ (widen)
+ (forward-line)
+ (while (not (eobp))
+ (if (looking-at "^-")
+ (insert "- "))
+ (forward-line))
+ (insert "\n-----BEGIN PGP SIGNATURE-----\n")
+ (insert "Version: " (car items) "\n\n")
+ (insert (mapconcat 'identity (cddr items) "\n"))
+ (insert "\n-----END PGP SIGNATURE-----\n")
+ (let ((mm-security-handle (list (format "multipart/signed"))))
+ (mml2015-clean-buffer)
+ (let ((coding-system-for-write (or gnus-newsgroup-charset
+ 'iso-8859-1)))
+ (funcall (mml2015-clear-verify-function)))
+ (setq info
+ (or (mm-handle-multipart-ctl-parameter
+ mm-security-handle 'gnus-details)
+ (mm-handle-multipart-ctl-parameter
+ mm-security-handle 'gnus-info)))))
+ (when info
+ (let (buffer-read-only bface eface)
+ (save-restriction
+ (message-narrow-to-head)
+ (goto-char (point-max))
+ (forward-line -1)
+ (setq bface (get-text-property (gnus-point-at-bol) 'face)
+ eface (get-text-property (1- (gnus-point-at-eol)) 'face))
+ (message-remove-header "X-Gnus-PGP-Verify")
+ (if (re-search-forward "^X-PGP-Sig:" nil t)
+ (forward-line)
+ (goto-char (point-max)))
+ (narrow-to-region (point) (point))
+ (insert "X-Gnus-PGP-Verify: " info "\n")
+ (goto-char (point-min))
+ (forward-line)
+ (while (not (eobp))
+ (if (not (looking-at "^[ \t]"))
+ (insert " "))
+ (forward-line))
+ ;; Do highlighting.
+ (goto-char (point-min))
+ (when (looking-at "\\([^:]+\\): *")
+ (put-text-property (match-beginning 1) (1+ (match-end 1))
+ 'face bface)
+ (put-text-property (match-end 0) (point-max)
+ 'face eface)))))))))
+
(eval-and-compile
(mapcar
(lambda (func)
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-verify-x-pgp-sig
article-hide-boring-headers
article-toggle-headers
article-treat-overstrike
article-remove-cr
article-display-x-face
article-de-quoted-unreadable
+ article-de-base64-unreadable
article-decode-HZ
+ article-wash-html
article-hide-list-identifiers
article-hide-pgp
article-strip-banner
">" end-of-buffer
"\C-c\C-i" gnus-info-find-node
"\C-c\C-b" gnus-bug
+ "\C-hk" gnus-article-describe-key
+ "\C-hc" gnus-article-describe-key-briefly
"\C-d" gnus-article-read-summary-keys
"\M-*" gnus-article-read-summary-keys
(decf c))
keys))))
+(eval-when-compile
+ (defvar gnus-article-commands-menu))
+
(defun gnus-article-make-menu-bar ()
(gnus-turn-off-edit-menu 'article)
(unless (boundp 'gnus-article-article-menu)
(define-key gnus-article-mode-map [menu-bar post]
(cons "Post" gnus-summary-post-menu)))
- (gnus-run-hooks 'gnus-article-menu-hook)))
+ (gnus-run-hooks 'gnus-article-menu-hook))
+ ;; Add the menu.
+ (when (boundp 'gnus-article-commands-menu)
+ (easy-menu-add gnus-article-commands-menu gnus-article-mode-map))
+ (when (boundp 'gnus-summary-post-menu)
+ (easy-menu-add gnus-summary-post-menu gnus-article-mode-map)))
(defun gnus-article-mode ()
"Major mode for displaying an article.
(make-local-variable 'gnus-article-decoded-p)
(make-local-variable 'gnus-article-mime-handle-alist)
(make-local-variable 'gnus-article-wash-types)
+ (make-local-variable 'gnus-article-charset)
+ (make-local-variable 'gnus-article-ignored-charsets)
(gnus-set-default-directory)
(buffer-disable-undo)
(setq buffer-read-only t)
;; Init original article buffer.
(save-excursion
(set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
+ (set-buffer-multibyte nil)
(setq major-mode 'gnus-original-article-mode)
(make-local-variable 'gnus-original-article))
(if (get-buffer name)
(mime-display-message mime-message-structure
gnus-article-buffer nil gnus-article-mode-map)
(when all-headers
- (gnus-article-hide-headers nil -1))
- )
- ;; `mime-display-message' changes current buffer to `gnus-article-buffer'.
- (make-local-variable 'mime-button-mother-dispatcher)
- (setq mime-button-mother-dispatcher
- (function gnus-article-push-button))
+ (gnus-article-hide-headers nil -1)))
(run-hooks 'gnus-mime-article-prepare-hook))
(defun gnus-article-display-traditional-message ()
(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-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-view-part-as-charset "C" "View As charset...")
(gnus-mime-save-part "o" "Save...")
+ (gnus-mime-save-part-and-strip "\C-o" "Save and Strip")
(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-pipe-part "|" "Pipe To Command...")
+ (gnus-mime-action-on-part "." "Take action on the part")))
(defun gnus-article-mime-part-status ()
(with-current-buffer gnus-article-buffer
(format " (%d parts)" (length (mime-entity-children entity)))
""))))
-(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))
+(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."
(interactive "e")
- (save-excursion
+ (save-window-excursion
(let ((pos (event-start event)))
- (set-buffer (window-buffer (posn-window pos)))
+ (select-window (posn-window pos))
(goto-char (posn-point pos))
(gnus-article-check-buffer)
(let ((response (x-popup-menu
(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."
(let ((handles (or handles gnus-article-mime-handles))
(mail-parse-charset gnus-newsgroup-charset)
(mail-parse-ignored-charsets
- (save-excursion (set-buffer gnus-summary-buffer)
- gnus-newsgroup-ignored-charsets)))
- (if (stringp (car handles))
- (gnus-mime-view-all-parts (cdr handles))
- (mapcar 'mm-display-part handles)))))
+ (with-current-buffer gnus-summary-buffer
+ gnus-newsgroup-ignored-charsets)))
+ (mm-remove-parts handles)
+ (goto-char (point-min))
+ (or (search-forward "\n\n") (goto-char (point-max)))
+ (let (buffer-read-only)
+ (delete-region (point) (point-max)))
+ (mm-display-parts handles))))
+
+(defun gnus-mime-save-part-and-strip ()
+ "Save the MIME part under point then replace it with an external body."
+ (interactive)
+ (gnus-article-check-buffer)
+ (let* ((data (get-text-property (point) 'gnus-data))
+ (file (mm-save-part data))
+ param)
+ (when file
+ (with-current-buffer (mm-handle-buffer data)
+ (erase-buffer)
+ (insert "Content-Type: " (mm-handle-media-type data))
+ (mml-insert-parameter-string (cdr (mm-handle-type data))
+ '(charset))
+ (insert "\n")
+ (insert "Content-ID: " (message-make-message-id) "\n")
+ (insert "Content-Transfer-Encoding: binary\n")
+ (insert "\n"))
+ (setcdr data
+ (cdr (mm-make-handle nil
+ `("message/external-body"
+ (access-type . "LOCAL-FILE")
+ (name . ,file)))))
+ (set-buffer gnus-summary-buffer)
+ (gnus-article-edit-article
+ `(lambda ()
+ (erase-buffer)
+ (let ((mail-parse-charset (or gnus-article-charset
+ ',gnus-newsgroup-charset))
+ (mail-parse-ignored-charsets
+ (or gnus-article-ignored-charsets
+ ',gnus-newsgroup-ignored-charsets))
+ (mbl mml-buffer-list))
+ (setq mml-buffer-list nil)
+ (insert-buffer gnus-original-article-buffer)
+ (mime-to-mml gnus-article-mime-handles)
+ (setq gnus-article-mime-handles nil)
+ (make-local-hook 'kill-buffer-hook)
+ (let ((mbl1 mml-buffer-list))
+ (setq mml-buffer-list mbl)
+ (set (make-local-variable 'mml-buffer-list) mbl1))
+ (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t)))
+ `(lambda (no-highlight)
+ (let ((mail-parse-charset (or gnus-article-charset
+ ',gnus-newsgroup-charset))
+ (message-options message-options)
+ (message-options-set-recipient)
+ (mail-parse-ignored-charsets
+ (or gnus-article-ignored-charsets
+ ',gnus-newsgroup-ignored-charsets)))
+ (mml-to-mime)
+ (mml-destroy-buffers)
+ (remove-hook 'kill-buffer-hook
+ 'mml-destroy-buffers t)
+ (kill-local-variable 'mml-buffer-list))
+ (gnus-summary-edit-article-done
+ ,(or (mail-header-references gnus-current-headers) "")
+ ,(gnus-group-read-only-p)
+ ,gnus-summary-buffer no-highlight))))))
(defun gnus-mime-save-part ()
"Save the MIME part under point."
(interactive
(list (completing-read
"View as MIME type: "
- (mapcar (lambda (i) (list i i)) (mailcap-mime-types))
+ (mapcar #'list (mailcap-mime-types))
nil nil
(gnus-mime-view-part-as-type-internal))))
(gnus-article-check-buffer)
(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)
+ (if (and (not arg) (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)
+ (if (mm-handle-undisplayer handle)
+ (mm-remove-part handle))
+ (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-view-part-as-charset (&optional handle arg)
+ "Insert the MIME part under point into the current buffer."
+ (interactive (list nil current-prefix-arg))
+ (gnus-article-check-buffer)
+ (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
+ contents charset
+ (b (point))
+ buffer-read-only)
+ (if (mm-handle-undisplayer handle)
+ (mm-remove-part handle))
+ (let ((gnus-newsgroup-charset
+ (or (cdr (assq arg
+ gnus-summary-show-article-charset-alist))
+ (read-coding-system "Charset: ")))
+ (gnus-newsgroup-ignored-charsets 'gnus-all))
+ (gnus-article-press-button))))
+
(defun gnus-mime-externalize-part (&optional handle)
"View the MIME part under point with an external viewer."
(interactive)
(gnus-article-check-buffer)
(let* ((handle (or handle (get-text-property (point) 'gnus-data)))
(mm-user-display-methods nil)
- (mm-inline-large-images nil)
+ (mm-inlined-types nil)
(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-copy-part))
+(defun gnus-article-view-part-as-charset (n)
+ "Copy MIME part N, which is the numerical prefix."
+ (interactive "p")
+ (gnus-article-part-wrapper n 'gnus-mime-view-part-as-charset))
+
(defun gnus-article-externalize-part (n)
"View MIME part N externally, which is the numerical prefix."
(interactive "p")
(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))
+ (gnus-article-mime-total-parts)
(mm-handle-media-type handle)))))
(select-window window))))
(goto-char point)
'name)
(mail-content-type-get (mm-handle-disposition handle)
'filename)
+ (mail-content-type-get (mm-handle-type handle)
+ 'url)
""))
(gnus-tmp-type (mm-handle-media-type handle))
(gnus-tmp-description
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))
(not gnus-mime-display-multipart-as-mixed))
;;;!!!We should find the start part, but we just default
;;;!!!to the first part.
- (gnus-mime-display-part (cadr handle)))
+ ;;(gnus-mime-display-part (cadr handle))
+ ;;;!!! Most multipart/related is an HTML message plus images.
+ ;;;!!! Unfortunately we are unable to let W3 display those
+ ;;;!!! included images, so we just display it as a mixed multipart.
+ (gnus-mime-display-mixed (cdr handle)))
+ ((equal (car handle) "multipart/signed")
+ (or (memq 'signed gnus-article-wash-types)
+ (push 'signed gnus-article-wash-types))
+ (gnus-mime-display-security handle))
+ ((equal (car handle) "multipart/encrypted")
+ (or (memq 'encrypted gnus-article-wash-types)
+ (push 'encrypted gnus-article-wash-types))
+ (gnus-mime-display-security handle))
;; Other multiparts are handled like multipart/mixed.
(t
(gnus-mime-display-mixed (cdr handle)))))
(setq display t)
(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-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)
+ ;(gnus-article-insert-newline)
+ ;; Remember modify the number of forward lines.
+ (setq move t))
+ (setq beg (point))
(cond
(display
(when move
- (forward-line -2)
+ (forward-line -1)
(setq beg (point)))
(let ((mail-parse-charset gnus-newsgroup-charset)
(mail-parse-ignored-charsets
(goto-char (point-max)))
((and text not-attachment)
(when move
- (forward-line -2)
+ (forward-line -1)
(setq beg (point)))
(gnus-article-insert-newline)
(mm-insert-inline handle (mm-get-part handle))
(save-restriction
(narrow-to-region beg (point))
(gnus-treat-article
- nil (length gnus-article-mime-handle-alist)
- (1- (length gnus-article-mime-handles))
+ nil id
+ (gnus-article-mime-total-parts)
(mm-handle-media-type handle)))))))))
(defun gnus-unbuttonized-mime-type-p (type)
(unless (setq not-pref (cadr (member preferred ihandles)))
(setq not-pref (car ihandles)))
(when (or ibegend
+ (not preferred)
(not (gnus-unbuttonized-mime-type-p
"multipart/alternative")))
(gnus-add-text-properties
(narrow-to-region (car begend) (point-max))
(gnus-treat-article
nil (length gnus-article-mime-handle-alist)
- (1- (length gnus-article-mime-handles))
+ (gnus-article-mime-total-parts)
(mm-handle-media-type handle))))))
(goto-char (point-max))
(setcdr begend (point-marker)))))
(boring (memq 'boring-headers gnus-article-wash-types))
(pgp (memq 'pgp gnus-article-wash-types))
(pem (memq 'pem gnus-article-wash-types))
+ (signed (memq 'signed gnus-article-wash-types))
+ (encrypted (memq 'encrypted gnus-article-wash-types))
(signature (memq 'signature gnus-article-wash-types))
(overstrike (memq 'overstrike gnus-article-wash-types))
(emphasis (memq 'emphasis gnus-article-wash-types)))
(format "%c%c%c%c%c%c%c"
(if cite ?c ? )
(if (or headers boring) ?h ? )
- (if (or pgp pem) ?p ? )
+ (if (or pgp pem signed encrypted) ?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.
(switch-to-buffer summary 'norecord))
(setq in-buffer (current-buffer))
;; We disable the pick minor mode commands.
- (if (setq func (let (gnus-pick-mode)
- (lookup-key (current-local-map) keys)))
+ (if (and (setq func (let (gnus-pick-mode)
+ (lookup-key (current-local-map) keys)))
+ (functionp func))
(progn
(call-interactively func)
- (setq new-sum-point (point)))
- (ding))
- (when (eq in-buffer (current-buffer))
- (setq selected (gnus-summary-select-article))
- (set-buffer obuf)
- (unless not-restore-window
- (set-window-configuration owin))
- (when (eq selected 'old)
- (article-goto-body)
- (set-window-start (get-buffer-window (current-buffer))
- 1)
- (set-window-point (get-buffer-window (current-buffer))
- (point)))
- (let ((win (get-buffer-window gnus-article-current-summary)))
- (when win
- (set-window-point win new-sum-point))))))))
+ (setq new-sum-point (point))
+ (when (eq in-buffer (current-buffer))
+ (setq selected (gnus-summary-select-article))
+ (set-buffer obuf)
+ (unless not-restore-window
+ (set-window-configuration owin))
+ (when (eq selected 'old)
+ (article-goto-body)
+ (set-window-start (get-buffer-window (current-buffer))
+ 1)
+ (set-window-point (get-buffer-window (current-buffer))
+ (point)))
+ (let ((win (get-buffer-window gnus-article-current-summary)))
+ (when win
+ (set-window-point win new-sum-point)))) )
+ (switch-to-buffer gnus-article-buffer)
+ (ding))))))
+
+(defun gnus-article-describe-key (key)
+ "Display documentation of the function invoked by KEY. KEY is a string."
+ (interactive "kDescribe key: ")
+ (gnus-article-check-buffer)
+ (if (eq (key-binding key) 'gnus-article-read-summary-keys)
+ (save-excursion
+ (set-buffer gnus-article-current-summary)
+ (let (gnus-pick-mode)
+ (push (elt key 0) unread-command-events)
+ (setq key (if (featurep 'xemacs)
+ (events-to-keys (read-key-sequence "Describe key: "))
+ (read-key-sequence "Describe key: "))))
+ (describe-key key))
+ (describe-key key)))
+
+(defun gnus-article-describe-key-briefly (key &optional insert)
+ "Display documentation of the function invoked by KEY. KEY is a string."
+ (interactive "kDescribe key: \nP")
+ (gnus-article-check-buffer)
+ (if (eq (key-binding key) 'gnus-article-read-summary-keys)
+ (save-excursion
+ (set-buffer gnus-article-current-summary)
+ (let (gnus-pick-mode)
+ (push (elt key 0) unread-command-events)
+ (setq key (if (featurep 'xemacs)
+ (events-to-keys (read-key-sequence "Describe key: "))
+ (read-key-sequence "Describe key: "))))
+ (describe-key-briefly key insert))
+ (describe-key-briefly key insert)))
(defun gnus-article-hide (&optional arg force)
"Hide all the gruft in the current article.
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))))))))
gnus-refer-article-method))
result
(buffer-read-only nil))
- (setq methods
- (if (listp methods)
- methods
- (list methods)))
+ (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)))
(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))
(defun gnus-article-edit-done (&optional arg)
"Update the article edits and exit."
(interactive "P")
- (save-excursion
- (save-restriction
- (widen)
- (when (article-goto-body)
- (let ((lines (count-lines (point) (point-max)))
- (length (- (point-max) (point)))
- (case-fold-search t)
- (body (copy-marker (point))))
- (goto-char (point-min))
- (when (re-search-forward "^content-length:[ \t]\\([0-9]+\\)" body t)
- (delete-region (match-beginning 1) (match-end 1))
- (insert (number-to-string length)))
- (goto-char (point-min))
- (when (re-search-forward
- "^x-content-length:[ \t]\\([0-9]+\\)" body t)
- (delete-region (match-beginning 1) (match-end 1))
- (insert (number-to-string length)))
- (goto-char (point-min))
- (when (re-search-forward "^lines:[ \t]\\([0-9]+\\)" body t)
- (delete-region (match-beginning 1) (match-end 1))
- (insert (number-to-string lines)))))))
(let ((func gnus-article-edit-done-function)
(buf (current-buffer))
(start (window-start)))
"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)))
;;; 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\\)\\)\\|[-a-zA-Z0-9_]+\\.[-a-zA-Z0-9_]+\\(\\.[-a-zA-Z0-9_]+[-a-zA-Z0-9_/]+\\)+"
+(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)
(nconc (and gnus-article-mouse-face
(list gnus-mouse-face-prop gnus-article-mouse-face))
(list 'gnus-callback fun)
- (and data (list 'gnus-data data)))))
+ (and data (list 'gnus-data data))))
+ (widget-convert-button 'link from to :action 'gnus-widget-press-button
+ ;; Quote `:button-keymap' for Mule 2.3
+ ;; but it won't work.
+ ':button-keymap gnus-widget-button-keymap))
;;; Internal functions:
(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 limit)
- (gnus-article-hide-text end limit gnus-hidden-properties)))))
+ (if (text-property-any end limit 'article-type 'signature)
+ (gnus-remove-text-properties-when
+ 'article-type 'signature end limit
+ (cons 'article-type (cons 'signature
+ gnus-hidden-properties)))
+ (gnus-add-text-properties-when
+ 'article-type nil end limit
+ (cons 'article-type (cons 'signature
+ gnus-hidden-properties)))))))
(defun gnus-button-entry ()
;; Return the first entry in `gnus-button-alist' matching this place.
(message-goto-subject)))))
(defun gnus-button-mailto (address)
- ;; Mail to ADDRESS.
+ "Mail to ADDRESS."
(set-buffer (gnus-copy-article-buffer))
- (gnus-setup-message 'reply
- (message-reply address)))
+ (message-reply address))
-(defun gnus-button-reply (address)
- ;; Reply to ADDRESS.
- (gnus-setup-message 'reply
- (message-reply address)))
+(defalias 'gnus-button-reply 'message-reply)
(defun gnus-button-embedded-url (address)
- "Browse ADDRESS."
+ "Activate ADDRESS with `browse-url'."
(browse-url (gnus-strip-whitespace address)))
(defun gnus-article-smiley-display ()
'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
((null val)
(t
(error "%S is not a valid value" val))))
+(defun gnus-article-encrypt-body (protocol &optional n)
+ "Encrypt the article body."
+ (interactive
+ (list
+ (or gnus-article-encrypt-protocol
+ (completing-read "Encrypt protocol: "
+ gnus-article-encrypt-protocol-alist
+ nil t))
+ current-prefix-arg))
+ (let ((func (cdr (assoc protocol gnus-article-encrypt-protocol-alist))))
+ (unless func
+ (error (format "Can't find the encrypt protocol %s" protocol)))
+ (if (equal gnus-newsgroup-name "nndraft:drafts")
+ (error "Can't encrypt the article in group nndraft:drafts."))
+ (if (equal gnus-newsgroup-name "nndraft:queue")
+ (error "Don't encrypt the article in group nndraft:queue."))
+ (gnus-summary-iterate n
+ (save-excursion
+ (set-buffer gnus-summary-buffer)
+ (let ((mail-parse-charset gnus-newsgroup-charset)
+ (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets)
+ (summary-buffer gnus-summary-buffer)
+ references point)
+ (gnus-set-global-variables)
+ (when (gnus-group-read-only-p)
+ (error "The current newsgroup does not support article encrypt"))
+ (gnus-summary-show-article t)
+ (setq references
+ (or (mail-header-references gnus-current-headers) ""))
+ (set-buffer gnus-article-buffer)
+ (let* ((buffer-read-only nil)
+ (headers
+ (mapcar (lambda (field)
+ (and (save-restriction
+ (message-narrow-to-head)
+ (goto-char (point-min))
+ (search-forward field nil t))
+ (prog2
+ (message-narrow-to-field)
+ (buffer-substring (point-min) (point-max))
+ (delete-region (point-min) (point-max))
+ (widen))))
+ '("Content-Type:" "Content-Transfer-Encoding:"
+ "Content-Disposition:"))))
+ (message-narrow-to-head)
+ (message-remove-header "MIME-Version")
+ (goto-char (point-max))
+ (setq point (point))
+ (insert (apply 'concat headers))
+ (widen)
+ (narrow-to-region point (point-max))
+ (let ((message-options message-options))
+ (message-options-set 'message-sender user-mail-address)
+ (message-options-set 'message-recipients user-mail-address)
+ (message-options-set 'message-sign-encrypt 'not)
+ (funcall func))
+ (goto-char (point-min))
+ (insert "MIME-Version: 1.0\n")
+ (widen)
+ (gnus-summary-edit-article-done
+ references nil summary-buffer t))
+ (when gnus-keep-backlog
+ (gnus-backlog-remove-article
+ (car gnus-article-current) (cdr gnus-article-current)))
+ (save-excursion
+ (when (get-buffer gnus-original-article-buffer)
+ (set-buffer gnus-original-article-buffer)
+ (setq gnus-original-article nil)))
+ (when gnus-use-cache
+ (gnus-cache-update-article
+ (car gnus-article-current) (cdr gnus-article-current))))))))
+
+(defvar gnus-mime-security-button-line-format "%{%([[%t:%i]%D]%)%}\n"
+ "The following specs can be used:
+%t The security MIME type
+%i Additional info
+%d Details
+%D Details if button is pressed")
+
+(defvar gnus-mime-security-button-end-line-format "%{%([[End of %t]%D]%)%}\n"
+ "The following specs can be used:
+%t The security MIME type
+%i Additional info
+%d Details
+%D Details if button is pressed")
+
+(defvar gnus-mime-security-button-line-format-alist
+ '((?t gnus-tmp-type ?s)
+ (?i gnus-tmp-info ?s)
+ (?d gnus-tmp-details ?s)
+ (?D gnus-tmp-pressed-details ?s)))
+
+(defvar gnus-mime-security-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 "\r" 'gnus-article-press-button)
+ map))
+
+(defvar gnus-mime-security-details-buffer nil)
+
+(defvar gnus-mime-security-button-pressed nil)
+
+(defvar gnus-mime-security-show-details-inline t
+ "If non-nil, show details in the article buffer.")
+
+(defun gnus-mime-security-verify-or-decrypt (handle)
+ (mm-remove-parts (cdr handle))
+ (let ((region (mm-handle-multipart-ctl-parameter handle 'gnus-region))
+ buffer-read-only)
+ (when region
+ (delete-region (car region) (cdr region))
+ (set-marker (car region) nil)
+ (set-marker (cdr region) nil)))
+ (with-current-buffer (mm-handle-multipart-original-buffer handle)
+ (let* ((mm-verify-option 'known)
+ (mm-decrypt-option 'known)
+ (nparts (mm-possibly-verify-or-decrypt (cdr handle) handle)))
+ (unless (eq nparts (cdr handle))
+ (mm-destroy-parts (cdr handle))
+ (setcdr handle nparts))))
+ (let ((point (point))
+ buffer-read-only)
+ (gnus-mime-display-security handle)
+ (goto-char point)))
+
+(defun gnus-mime-security-show-details (handle)
+ (let ((details (mm-handle-multipart-ctl-parameter handle 'gnus-details)))
+ (if details
+ (if gnus-mime-security-show-details-inline
+ (let ((gnus-mime-security-button-pressed t)
+ (gnus-mime-security-button-line-format
+ (get-text-property (point) 'gnus-line-format))
+ buffer-read-only)
+ (forward-char -1)
+ (while (eq (get-text-property (point) 'gnus-line-format)
+ gnus-mime-security-button-line-format)
+ (forward-char -1))
+ (forward-char)
+ (delete-region (point)
+ (or (text-property-not-all
+ (point) (point-max)
+ 'gnus-line-format
+ gnus-mime-security-button-line-format)
+ (point-max)))
+ (gnus-insert-mime-security-button handle))
+ (if (gnus-buffer-live-p gnus-mime-security-details-buffer)
+ (with-current-buffer gnus-mime-security-details-buffer
+ (erase-buffer)
+ t)
+ (setq gnus-mime-security-details-buffer
+ (gnus-get-buffer-create "*MIME Security Details*")))
+ (with-current-buffer gnus-mime-security-details-buffer
+ (insert details)
+ (goto-char (point-min)))
+ (pop-to-buffer gnus-mime-security-details-buffer))
+ (gnus-message 5 "No details."))))
+
+(defun gnus-mime-security-press-button (handle)
+ (if (mm-handle-multipart-ctl-parameter handle 'gnus-info)
+ (gnus-mime-security-show-details handle)
+ (gnus-mime-security-verify-or-decrypt handle)))
+
+(defun gnus-insert-mime-security-button (handle &optional displayed)
+ (let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol))
+ (gnus-tmp-type
+ (concat
+ (or (nth 2 (assoc protocol mm-verify-function-alist))
+ (nth 2 (assoc protocol mm-decrypt-function-alist))
+ "Unknown")
+ (if (equal (car handle) "multipart/signed")
+ " Signed" " Encrypted")
+ " Part"))
+ (gnus-tmp-info
+ (or (mm-handle-multipart-ctl-parameter handle 'gnus-info)
+ "Undecided"))
+ (gnus-tmp-details
+ (mm-handle-multipart-ctl-parameter handle 'gnus-details))
+ gnus-tmp-pressed-details
+ b e)
+ (setq gnus-tmp-details
+ (if gnus-tmp-details
+ (concat "\n" gnus-tmp-details) ""))
+ (setq gnus-tmp-pressed-details
+ (if gnus-mime-security-button-pressed gnus-tmp-details ""))
+ (unless (bolp)
+ (insert "\n"))
+ (setq b (point))
+ (gnus-eval-format
+ gnus-mime-security-button-line-format
+ gnus-mime-security-button-line-format-alist
+ `(local-map ,gnus-mime-security-button-map
+ keymap ,gnus-mime-security-button-map
+ gnus-callback gnus-mime-security-press-button
+ gnus-line-format ,gnus-mime-security-button-line-format
+ article-type annotation
+ gnus-data ,handle))
+ (setq e (point))
+ (widget-convert-button
+ 'link b e
+ :mime-handle handle
+ :action 'gnus-widget-press-button
+ :button-keymap gnus-mime-security-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: show detail"
+ (aref gnus-mouse-2 0))))))
+
+(defun gnus-mime-display-security (handle)
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (gnus-insert-mime-security-button handle)
+ (gnus-mime-display-mixed (cdr handle))
+ (unless (bolp)
+ (insert "\n"))
+ (let ((gnus-mime-security-button-line-format
+ gnus-mime-security-button-end-line-format))
+ (gnus-insert-mime-security-button handle))
+ (mm-set-handle-multipart-parameter handle 'gnus-region
+ (cons (set-marker (make-marker)
+ (point-min))
+ (set-marker (make-marker)
+ (point-max))))))
+
;;; @ for mime-view
;;;
projects / elisp / gnus.git- / blobdiff