X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-art.el;h=730f06c8671015d1cee51821fd2795da94f5d26f;hb=5f7d6a0119cdbcd726e5a573b3e33a6649fd3bfa;hp=b9751e5921844a658df0eda0e8e9f172d9ff2236;hpb=fc1ac980dd57a4c165e9ab05d6df2065574eedc6;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index b9751e5..730f06c 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -37,6 +37,7 @@ (require 'gnus-int) (require 'alist) (require 'mime-view) +(require 'wid-edit) ;; Avoid byte-compile warnings. (eval-when-compile @@ -44,7 +45,6 @@ (require 'mail-parse) (require 'mm-decode) (require 'mm-view) - (require 'wid-edit) (require 'mm-uu) ) @@ -212,10 +212,11 @@ regexp. If it matches, the text in question is not a signature." (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 gnus-xemacs) + ((and (not (featurep 'xemacs)) window-system (module-installed-p 'x-face-mule)) 'x-face-mule-gnus-article-display-x-face) @@ -235,6 +236,13 @@ asynchronously. The compressed face will be piped to this command." :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)\\)") @@ -623,8 +631,8 @@ displayed by the first non-nil matching CONTENT face." ("\223" "``") ("\224" "\"") ("\225" "*") - ("\226" "---") - ("\227" "-") + ("\226" "-") + ("\227" "--") ("\231" "(TM)") ("\233" ">") ("\234" "oe") @@ -675,6 +683,20 @@ used." :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 ;;; @@ -776,6 +798,13 @@ 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. @@ -901,11 +930,12 @@ See the manual for details." (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)) + (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." @@ -914,8 +944,11 @@ 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 @@ -927,7 +960,7 @@ 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." @@ -994,6 +1027,7 @@ See the manual for details." (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) @@ -1358,7 +1392,7 @@ if given a positive prefix, always hide." (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))) @@ -1656,30 +1690,57 @@ If FORCE, decode the article whether it is marked as quoted-printable 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 (string-match "quoted-printable" (downcase type)))) + (and type (let ((case-fold-search t)) + (string-match "quoted-printable" type)))) (article-goto-body) - (quoted-printable-decode-region (point) (point-max) charset))))) + (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 (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 (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)) (base64-decode-region (point-min) (point-max)) - (if (mm-coding-system-p charset) - (mm-decode-coding-region (point-min) (point-max) charset))))))) + (mm-decode-coding-region + (point-min) (point-max) (mm-charset-to-coding-system charset))))))) (eval-when-compile (require 'rfc1843)) @@ -1697,7 +1758,19 @@ If FORCE, decode the article whether it is marked as base64 not." (interactive) (save-excursion (let ((buffer-read-only nil) - (charset gnus-newsgroup-charset)) + 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 @@ -1801,7 +1874,7 @@ always hide." (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 @@ -1812,6 +1885,10 @@ always hide." (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)))))))))) @@ -2412,8 +2489,8 @@ This format is defined by the `gnus-article-time-format' variable." (let ((default-name (funcall function group headers (symbol-value variable))) result) - (setq - result + (setq result + (expand-file-name (cond ((eq filename 'default) default-name) @@ -2478,10 +2555,10 @@ This format is defined by the `gnus-article-time-format' variable." (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))) @@ -2647,7 +2724,7 @@ 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 @@ -2854,6 +2931,7 @@ commands: ;; 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) @@ -2904,12 +2982,7 @@ commands: (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 () @@ -3041,6 +3114,8 @@ If ALL-HEADERS is non-nil, no headers are hidden." (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) @@ -3210,7 +3285,8 @@ value of the variable `gnus-show-mime' is non-nil." (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 @@ -3219,15 +3295,14 @@ value of the variable `gnus-show-mime' is non-nil." (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." @@ -3293,7 +3368,7 @@ value of the variable `gnus-show-mime' is non-nil." (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) @@ -3331,19 +3406,35 @@ value of the variable `gnus-show-mime' is non-nil." (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) @@ -3377,6 +3468,16 @@ In no internal viewer is available, use an external viewer." (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) @@ -3452,6 +3553,11 @@ In no internal viewer is available, use an external viewer." (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)) @@ -3485,7 +3591,7 @@ In no internal viewer is available, use an external viewer." (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) @@ -3537,21 +3643,30 @@ In no internal viewer is available, use an external viewer." 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)) @@ -3664,7 +3779,8 @@ In no internal viewer is available, use an external viewer." (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))) @@ -3673,8 +3789,8 @@ In no internal viewer is available, use an external viewer." handle id (list (or display (and not-attachment text)))) (gnus-article-insert-newline) ;(gnus-article-insert-newline) - (setq move t))) - (let ((beg (point))) + (setq move t)) + (setq beg (point)) (cond (display (when move @@ -3700,8 +3816,8 @@ In no internal viewer is available, use an external viewer." (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) @@ -3803,7 +3919,7 @@ In no internal viewer is available, use an external viewer." (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))))) @@ -4164,11 +4280,11 @@ If given a prefix, show the hidden text instead." 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)))))))) @@ -4207,10 +4323,10 @@ If given a prefix, show the hidden text instead." 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))) @@ -4249,6 +4365,7 @@ If given a prefix, show the hidden text instead." (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)) @@ -4851,7 +4968,11 @@ specified by `gnus-button-alist'." (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: @@ -5003,18 +5124,14 @@ forbidden in URL encoding." (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 () @@ -5197,11 +5314,13 @@ For example: '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)