X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-art.el;h=d8f5fe0edc954e1bcb92fbcbd774f7376bd852b6;hb=91a0e9f6bf84b6a4e011e8104ca68bda9135dcb2;hp=a4327b29709e9a950069caa9a7bbeebef07b393d;hpb=ab5e42a0756eda2425c8dccc26c80267463080ba;p=gnus diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index a4327b297..d8f5fe0ed 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -200,6 +200,7 @@ regexp. If it matches, the text in question is not a signature." ;; Fixme: This isn't the right thing for mixed graphical and and ;; non-graphical frames in a session. +;; gnus-xmas.el overrides this for XEmacs. (defcustom gnus-article-x-face-command (if (and (fboundp 'image-type-available-p) (image-type-available-p 'xbm)) @@ -218,6 +219,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)\\)") @@ -646,6 +654,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 ;;; @@ -870,8 +892,11 @@ 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 + (and (or (and (fboundp 'image-type-available-p) + (image-type-available-p 'xbm)) + (and gnus-xemacs (featurep 'xface))) + 'head) "Display X-Face headers. Valid values are nil, t, `head', `last', an integer or a predicate. See the manual for details." @@ -1509,9 +1534,21 @@ 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)))) (article-goto-body) @@ -1522,9 +1559,21 @@ or not." 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 "base64" (downcase type)))) (article-goto-body) @@ -1550,7 +1599,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 @@ -1654,7 +1715,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 @@ -1665,6 +1726,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)))))))))) @@ -2221,8 +2286,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) @@ -2287,10 +2352,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))) @@ -2456,7 +2521,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 @@ -2652,7 +2717,10 @@ commands: (save-excursion (set-buffer name) (when gnus-article-mime-handles - (mm-destroy-parts gnus-article-mime-handles)) + (mm-destroy-parts gnus-article-mime-handles) + (setq gnus-article-mime-handles nil)) + ;; Set it to nil in article-buffer! + (setq gnus-article-mime-handle-alist nil) (buffer-disable-undo) (setq buffer-read-only t) (unless (eq major-mode 'gnus-article-mode) @@ -2770,6 +2838,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) @@ -2835,22 +2905,22 @@ If ALL-HEADERS is non-nil, no headers are hidden." (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 () (if gnus-article-mime-handle-alist-1 (format " (%d parts)" (length gnus-article-mime-handle-alist-1)) "")) -(defvar gnus-mime-button-map nil) -(unless gnus-mime-button-map - (setq gnus-mime-button-map (make-sparse-keymap)) - (set-keymap-parent gnus-mime-button-map gnus-article-mode-map) - (define-key gnus-mime-button-map gnus-mouse-2 'gnus-article-push-button) - (define-key gnus-mime-button-map gnus-down-mouse-3 'gnus-mime-button-menu) - (mapcar (lambda (c) - (define-key gnus-mime-button-map (cadr c) (car c))) - gnus-mime-button-commands)) +(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." @@ -2916,7 +2986,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (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) @@ -2954,19 +3024,31 @@ If ALL-HEADERS is non-nil, no headers are hidden." (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 charset + (mm-decode-coding-string contents charset) + contents)) (goto-char b)))) (defun gnus-mime-externalize-part (&optional handle) @@ -3000,6 +3082,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) @@ -3160,21 +3252,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)) @@ -3779,11 +3880,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)))))))) @@ -4642,11 +4743,13 @@ For example: (funcall (cadr elem))))))) ;; 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)