;;; Code:
(eval-when-compile (require 'cl))
+(eval-when-compile (require 'static))
+(require 'path-util)
(require 'custom)
(require 'gnus)
(require 'gnus-sum)
(require 'alist)
(require 'mime-view)
+;; Avoid byte-compile warnings.
+(defvar gnus-article-decoded-p)
+(defvar gnus-article-mime-handles)
(eval-when-compile
- (require 'static)
- ;; Avoid byte-compile warnings.
- (defvar gnus-article-decoded-p)
- (defvar gnus-article-mime-handles)
(require 'mm-bodies)
(require 'mail-parse)
(require 'mm-decode)
:group 'gnus-article-hiding)
(defcustom gnus-article-x-face-command
- "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | display -"
+ (if (and (not gnus-xemacs)
+ window-system
+ (module-installed-p 'x-face-mule))
+ 'x-face-mule-gnus-article-display-x-face
+ "{ 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."
: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)
: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)))
+
;;;
;;; The treatment variables
;;;
: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."
: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
+ (if (or (and gnus-xemacs (featurep 'xface))
+ (eq 'x-face-mule-gnus-article-display-x-face
+ gnus-article-x-face-command))
+ 'head
+ nil)
"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 gnus-xemacs (featurep 'xpm))
+ (and (not gnus-xemacs)
+ window-system
+ (module-installed-p 'smiley-mule)))
+ t
+ nil)
"Display smileys.
Valid values are nil, t, `head', `last', an integer or a predicate.
See the manual for details."
(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-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-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-treat-buttonize-head gnus-article-add-buttons-to-head)
(gnus-treat-display-smileys gnus-smiley-display)
(gnus-treat-display-picons gnus-article-display-picons)
- (gnus-treat-play-sounds gnus-earcon-display)
- (gnus-treat-decode-article-as-default-mime-charset
- gnus-article-decode-article-as-default-mime-charset)))
+ (gnus-treat-play-sounds gnus-earcon-display)))
(defvar gnus-article-mime-handle-alist nil)
(defvar article-lapsed-timer nil)
(when (setq beg (text-property-any
(point-min) (point-max) 'message-rank (+ 2 max)))
;; We delete or make invisible the unwanted headers.
+ (push 'headers gnus-article-wash-types)
(if delete
(progn
(add-text-properties
(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)
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)
+ (or (next-single-property-change (1+ button) 'mime-view-entity)
+ (point-max))
+ 'signature))))))))
(defun article-strip-headers-in-body ()
"Strip offensive headers from bodies."
(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'."
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))
highlight)
(copy-list highlight-words)
(if gnus-newsgroup-name
- (copy-list (gnus-group-find-parameter
+ (copy-list (gnus-group-find-parameter
gnus-newsgroup-name 'highlight-words t)))
gnus-emphasis-alist)))))
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
(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)))
- (number (or number 0))
- next type ids)
+ (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)
(goto-char (point-max)))
(while (and (not (eobp))
entity
- (setq next (next-single-property-change (point)
- 'mime-view-entity)))
- (setq type (mime-entity-content-type entity)
- type (format "%s/%s"
- (mime-content-type-primary-type type)
- (mime-content-type-subtype type)))
+ (setq next
+ (set-marker
+ (make-marker)
+ (or (next-single-property-change (point)
+ 'mime-view-entity)
+ (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")
- (save-restriction
- (narrow-to-region (point) (point-max))
- (gnus-article-prepare-mime-display number)
- (goto-char (point-max)))
- (setq ids (length (mime-entity-node-id entity))
- entity (get-text-property next 'mime-view-entity)
- number (1+ number))
+ (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))))))
+ (setq next (or (next-single-property-change next 'mime-view-entity)
+ (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)
- (if (or (null entity)
- (< (length (mime-entity-node-id entity)) ids))
- (gnus-treat-article 'last number number type)
- (gnus-treat-article t number nil type))
- (goto-char (point-max)))))
- (unless (eobp)
- (save-restriction
- (narrow-to-region (point) (point-max))
- (if entity
- (progn
- (setq type (mime-entity-content-type entity)
- type (format "%s/%s"
- (mime-content-type-primary-type type)
- (mime-content-type-subtype type)))
- (if (string-equal type "message/rfc822")
- (gnus-article-prepare-mime-display number)
- (incf number)
- (gnus-treat-article 'last number number type)))
- (gnus-treat-article t))))))
+ ;; 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)
+ (setq entity (get-text-property next 'mime-view-entity))
+ (goto-char (point-max)))))))
;;;###autoload
(defun gnus-article-prepare-display ()
(gnus-run-hooks 'gnus-tmp-internal-hook)
(gnus-run-hooks 'gnus-article-prepare-hook)
;; Display message.
- (let (mime-display-header-hook)
+ (let (mime-display-header-hook mime-display-text/plain-hook)
(funcall (if gnus-show-mime
(progn
(setq mime-message-structure gnus-current-headers)
(goto-char (point-max))
(widen)
(narrow-to-region (point) (point-max))
- (gnus-treat-article t))
+ (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.
(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))))
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."
(save-excursion
(set-buffer gnus-article-buffer)
(let ((buffer-read-only nil)
- (inhibit-point-motion-hooks t))
+ (inhibit-point-motion-hooks t)
+ (limit (or (next-single-property-change end 'mime-view-entity)
+ (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.
(entity (static-unless (featurep 'xemacs)
(when (eq 'head condition)
(get-text-property (point-min) 'mime-view-entity))))
- val elem)
+ val elem buttonized)
(gnus-run-hooks 'gnus-part-display-hook)
(unless gnus-inhibit-treatment
(while (setq elem (pop alist))
(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
(defvar length)
(defun gnus-treat-predicate (val)
(cond
- ((eq val 'mime)
- (not (not gnus-show-mime)))
((null val)
nil)
+ ((and (listp val)
+ (stringp (car val)))
+ (apply 'gnus-or (mapcar `(lambda (s)
+ (string-match s ,(or gnus-newsgroup-name "")))
+ val)))
((listp val)
(let ((pred (pop val)))
(cond
((eq pred 'not)
(not (gnus-treat-predicate (car val))))
((eq pred 'typep)
- (equal (cadr val) type))
+ (equal (car val) type))
(t
- (gnus-treat-predicate pred)))))
+ (error "%S is not a valid predicate" pred)))))
+ ((eq val 'mime)
+ gnus-show-mime)
(condition
(eq condition val))
((eq val t)
(eq part-number total-parts))
((numberp val)
(< length val))
- ((and (listp val)
- (stringp (car val)))
- (apply 'gnus-or (mapcar `(lambda (s)
- (string-match s ,(or gnus-newsgroup-name "")))
- val)))
(t
(error "%S is not a valid value" val))))
(set-alist 'mime-preview-quitting-method-alist
'gnus-original-article-mode #'gnus-mime-preview-quitting-method)
-(defun gnus-following-method (buf)
- (set-buffer buf)
- (message-followup)
- (message-yank-original)
- (kill-buffer buf)
- (goto-char (point-min))
- )
-
(set-alist 'mime-preview-following-method-alist
'gnus-original-article-mode #'gnus-following-method)
projects / elisp / gnus.git- / blobdiff