X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-art.el;h=a10d3de63482d8a30d20c7bfd9a27b165204b71d;hb=1774ae25842f79d393cc8dd84a43e8eb9224d4ce;hp=e36f60e1ed960f44ff51d988a245d4cd9ed844f3;hpb=29d88dc82d12421f6616ab1dcd11a3035a0875ee;p=gnus diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index e36f60e1e..a10d3de63 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -97,7 +97,7 @@ (defcustom gnus-ignored-headers '("^Path:" "^Expires:" "^Date-Received:" "^References:" "^Xref:" "^Lines:" - "^Relay-Version:" "^Message-ID:" "^Approved:" "^Sender:" "^Received:" + "^Relay-Version:" "^Message-ID:" "^Approved:" "^Sender:" "^Received:" "^X-UIDL:" "^MIME-Version:" "^Return-Path:" "^In-Reply-To:" "^Content-Type:" "^Content-Transfer-Encoding:" "^X-WebTV-Signature:" "^X-MimeOLE:" "^X-MSMail-Priority:" "^X-Priority:" "^X-Loop:" @@ -107,7 +107,7 @@ "^X-Complaints-To:" "^X-NNTP-Posting-Host:" "^X-Orig.*:" "^Abuse-Reports-To:" "^Cache-Post-Path:" "^X-Article-Creation-Date:" "^X-Poster:" "^X-Mail2News-Path:" "^X-Server-Date:" "^X-Cache:" - "^Originator:" "^X-Problems-To:" "^X-Auth-User:" "^X-Post-Time:" + "^Originator:" "^X-Problems-To:" "^X-Auth-User:" "^X-Post-Time:" "^X-Admin:" "^X-UID:" "^Resent-[-A-Za-z]+:" "^X-Mailing-List:" "^Precedence:" "^Original-[-A-Za-z]+:" "^X-filename:" "^X-Orcpt:" "^Old-Received:" "^X-Pgp-Fingerprint:" "^X-Pgp-Key-Id:" @@ -546,8 +546,29 @@ displayed by the first non-nil matching CONTENT face." (defvar gnus-decode-header-function 'mail-decode-encoded-word-region "Function used to decode headers.") +(defvar gnus-article-dumbquotes-map + '(("\202" . ",") + ("\203" . "f") + ("\204" . ",,") + ("\213" . "<") + ("\214" . "OE") + ("\205" . "...") + ("\221" . "`") + ("\222" . "'") + ("\223" . "``") + ("\224" . "''") + ("\225" . "*") + ("\226" . "-") + ("\227" . "-") + ("\231" . "(TM)") + ("\233" . ">") + ("\234" . "oe") + ("\264" . "'")) + "Table for MS-to-Latin1 translation.") + ;;; Internal variables +(defvar gnus-article-mime-handle-alist nil) (defvar article-lapsed-timer nil) (defvar gnus-article-current-summary nil) @@ -807,7 +828,7 @@ always hide." (defun article-treat-dumbquotes () "Translate M******** sm*rtq**t*s into proper text." (interactive) - (article-translate-characters "\221\222\223\224" "`'\"\"")) + (article-translate-strings gnus-article-dumbquotes-map)) (defun article-translate-characters (from to) "Translate all characters in the body of the article according to FROM and TO. @@ -827,6 +848,19 @@ characters to translate to." (incf i)) (translate-region (point) (point-max) x))))) +(defun article-translate-strings (map) + "Translate all string in the body of the article according to MAP. +MAP is an alist where the elements are on the form (\"from\" \"to\")." + (save-excursion + (goto-char (point-min)) + (when (search-forward "\n\n" nil t) + (let ((buffer-read-only nil) + elem) + (while (setq elem (pop map)) + (save-excursion + (while (search-forward (car elem) nil t) + (replace-match (cadr elem))))))))) + (defun article-treat-overstrike () "Translate overstrikes into bold text." (interactive) @@ -965,6 +999,7 @@ If PROMPT (the prefix), prompt for a coding system to use." (save-restriction (message-narrow-to-head) (let* ((inhibit-point-motion-hooks t) + (case-fold-search t) (ct (message-fetch-field "Content-Type" t)) (cte (message-fetch-field "Content-Transfer-Encoding" t)) (ctl (and ct (condition-case () @@ -981,6 +1016,7 @@ If PROMPT (the prefix), prompt for a coding system to use." buffer-read-only) (goto-char (point-max)) (widen) + (forward-line 1) (narrow-to-region (point) (point-max)) (when (or (not ct) (equal (car ctl) "text/plain")) @@ -1008,7 +1044,9 @@ or not." (and type (string-match "quoted-printable" (downcase type)))) (goto-char (point-min)) (search-forward "\n\n" nil 'move) - (quoted-printable-decode-region (point) (point-max)))))) + (quoted-printable-decode-region (point) (point-max)) + (when mm-default-coding-system + (mm-decode-body mm-default-coding-system)))))) (defun article-mime-decode-quoted-printable-buffer () "Decode Quoted-Printable in the current buffer." @@ -1028,6 +1066,9 @@ always hide." ;; Hide the "header". (when (search-forward "\n-----BEGIN PGP SIGNED MESSAGE-----\n" nil t) (delete-region (1+ (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)))) (setq beg (point)) ;; Hide the actual signature. (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t) @@ -1455,11 +1496,13 @@ function and want to see what the date was before converting." (let (deactivate-mark) (save-excursion (ignore-errors - (when (gnus-buffer-live-p gnus-article-buffer) - (set-buffer gnus-article-buffer) - (goto-char (point-min)) - (when (re-search-forward "^X-Sent:" nil t) - (article-date-lapsed t))))))) + (walk-windows + (lambda (w) + (set-buffer (window-buffer w)) + (when (eq major-mode 'gnus-article-mode) + (goto-char (point-min)) + (when (re-search-forward "^X-Sent:" nil t) + (article-date-lapsed t))))))))) (defun gnus-start-date-timer (&optional n) "Start a timer to update the X-Sent header in the article buffers. @@ -1728,7 +1771,8 @@ The directory to save in defaults to `gnus-article-save-directory'." (defun gnus-summary-save-in-pipe (&optional command) "Pipe this article to subprocess." (setq command - (cond ((eq command 'default) + (cond ((and (eq command 'default) + gnus-last-shell-command) gnus-last-shell-command) (command command) (t (read-string @@ -1876,7 +1920,6 @@ If variable `gnus-use-long-file-name' is non-nil, it is " " gnus-article-goto-next-page "\177" gnus-article-goto-prev-page [delete] gnus-article-goto-prev-page - "\r" widget-button-press "\C-c^" gnus-article-refer-article "h" gnus-article-show-summary "s" gnus-article-show-summary @@ -1957,8 +2000,10 @@ commands: (make-local-variable 'gnus-button-marker-list) (make-local-variable 'gnus-article-current-summary) (make-local-variable 'gnus-article-mime-handles) + (make-local-variable 'gnus-article-decoded-p) + (make-local-variable 'gnus-article-mime-handle-alist) (gnus-set-default-directory) - (buffer-disable-undo (current-buffer)) + (buffer-disable-undo) (setq buffer-read-only t) (set-syntax-table gnus-article-mode-syntax-table) (mm-enable-multibyte) @@ -1974,6 +2019,7 @@ commands: (substring name (match-end 0)))))) (setq gnus-article-buffer name) (setq gnus-original-article-buffer original) + (setq gnus-article-mime-handle-alist nil) ;; This might be a variable local to the summary buffer. (unless gnus-single-article-buffer (save-excursion @@ -1990,7 +2036,7 @@ commands: (if (get-buffer name) (save-excursion (set-buffer name) - (buffer-disable-undo (current-buffer)) + (buffer-disable-undo) (setq buffer-read-only t) (unless (eq major-mode 'gnus-article-mode) (gnus-article-mode)) @@ -1999,6 +2045,7 @@ commands: (set-buffer (gnus-get-buffer-create name)) (gnus-article-mode) (make-local-variable 'gnus-summary-buffer) + (gnus-summary-set-local-parameters gnus-newsgroup-name) (current-buffer))))) ;; Set article window start at LINE, where LINE is the number of lines @@ -2109,15 +2156,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (or all-headers gnus-show-all-headers)))) (when (or (numberp article) (stringp article)) - ;; Hooks for getting information from the article. - ;; This hook must be called before being narrowed. - (let (buffer-read-only) - (gnus-run-hooks 'gnus-tmp-internal-hook) - (gnus-run-hooks 'gnus-article-prepare-hook) - (when gnus-display-mime-function - (funcall gnus-display-mime-function)) - ;; Perform the article display hooks. - (gnus-run-hooks 'gnus-article-display-hook)) + (gnus-article-prepare-display) ;; Do page break. (goto-char (point-min)) (setq gnus-page-broken @@ -2131,26 +2170,74 @@ If ALL-HEADERS is non-nil, no headers are hidden." (set-window-point (get-buffer-window (current-buffer)) (point)) t)))))) +(defun gnus-article-prepare-display () + "Make the current buffer look like a nice article." + ;; Hooks for getting information from the article. + ;; This hook must be called before being narrowed. + (let ((gnus-article-buffer (current-buffer)) + buffer-read-only) + (unless (eq major-mode 'gnus-article-mode) + (gnus-article-mode)) + (setq buffer-read-only nil) + (gnus-run-hooks 'gnus-tmp-internal-hook) + (gnus-run-hooks 'gnus-article-prepare-hook) + (when gnus-display-mime-function + (let ((url-standalone-mode (not gnus-plugged))) + (funcall gnus-display-mime-function))) + ;; Perform the article display hooks. + (gnus-run-hooks 'gnus-article-display-hook))) + ;;; ;;; Gnus MIME viewing functions ;;; -(defvar gnus-mime-button-line-format "%{%([%t%d%n]%)%}\n") +(defvar gnus-mime-button-line-format "%{%([%p. %t%d%n]%)%}%e\n" + "The following specs can be used: +%t The MIME type +%n The `name' parameter +%d The description, if any +%l The length of the encoded part +%p The part identifier +%e Dots if the part isn't displayed") + (defvar gnus-mime-button-line-format-alist '((?t gnus-tmp-type ?s) (?n gnus-tmp-name ?s) - (?d gnus-tmp-description ?s))) + (?d gnus-tmp-description ?s) + (?p gnus-tmp-id ?s) + (?l gnus-tmp-length ?d) + (?e gnus-tmp-dots ?s))) + +(defvar gnus-mime-button-commands + '((gnus-article-press-button "\r" "Toggle Display") + ;(gnus-mime-view-part "\M-\r" "View Interactively...") + (gnus-mime-view-part "v" "View Interactively...") + (gnus-mime-save-part "o" "Save...") + (gnus-mime-copy-part "c" "View In Buffer") + (gnus-mime-inline-part "i" "View Inline") + (gnus-mime-pipe-part "|" "Pipe To Command..."))) (defvar gnus-mime-button-map nil) (unless gnus-mime-button-map - (setq gnus-mime-button-map (copy-keymap gnus-article-mode-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 "\r" 'gnus-article-press-button) - (define-key gnus-mime-button-map "\M-\r" 'gnus-mime-view-part) - (define-key gnus-mime-button-map "v" 'gnus-mime-view-part) - (define-key gnus-mime-button-map "o" 'gnus-mime-save-part) - (define-key gnus-mime-button-map "c" 'gnus-mime-copy-part) - (define-key gnus-mime-button-map "|" 'gnus-mime-pipe-part)) + (define-key gnus-mime-button-map gnus-mouse-3 'gnus-mime-button-menu) + (mapcar (lambda (c) + (define-key gnus-mime-button-map (cadr c) (car c))) + gnus-mime-button-commands)) + +(defun gnus-mime-button-menu (event) + "Construct a context-sensitive menu of MIME commands." + (interactive "e") + ) + +(defun gnus-mime-view-all-parts () + "View all the MIME parts." + (interactive) + (let ((handles gnus-article-mime-handles)) + (while handles + (mm-display-part (pop handles))))) (defun gnus-mime-save-part () "Save the MIME part under point." @@ -2167,44 +2254,103 @@ If ALL-HEADERS is non-nil, no headers are hidden." (defun gnus-mime-view-part () "Interactively choose a view method for the MIME part under point." (interactive) - (let ((data (get-text-property (point) 'gnus-data))) + (let ((data (get-text-property (point) 'gnus-data)) + (url-standalone-mode (not gnus-plugged))) (mm-interactively-view-part data))) (defun gnus-mime-copy-part () "Put the the MIME part under point into a new buffer." (interactive) - (let* ((data (get-text-property (point) 'gnus-data)) - (contents (mm-get-part data))) - (switch-to-buffer (generate-new-buffer "*decoded*")) + (let* ((handle (get-text-property (point) 'gnus-data)) + (contents (mm-get-part handle)) + (buffer (generate-new-buffer + (file-name-nondirectory + (or + (mail-content-type-get (mm-handle-type handle) 'name) + (mail-content-type-get (mm-handle-type handle) + 'filename) + "*decoded*"))))) + (set-buffer-major-mode buffer) + (switch-to-buffer buffer) (insert contents) (goto-char (point-min)))) -(defun gnus-insert-mime-button (handle) +(defun gnus-mime-inline-part () + "Insert the MIME part under point into the current buffer." + (interactive) + (let* ((data (get-text-property (point) 'gnus-data)) + (contents (mm-get-part data)) + (url-standalone-mode (not gnus-plugged)) + (b (point)) + buffer-read-only) + (if (mm-handle-undisplayer data) + (mm-remove-part data) + (forward-line 2) + (mm-insert-inline data contents) + (goto-char b)))) + +(defun gnus-article-view-part (n) + "View MIME part N, which is the numerical prefix." + (interactive "p") + (save-current-buffer + (set-buffer gnus-article-buffer) + (when (> n (length gnus-article-mime-handle-alist)) + (error "No such part")) + (let ((handle (cdr (assq n gnus-article-mime-handle-alist)))) + (gnus-article-goto-part n) + (gnus-set-window-start) + (gnus-mm-display-part handle)))) + +(defun gnus-mm-display-part (handle) + "Display HANDLE and fix MIME button." + (let ((id (get-text-property (point) 'gnus-part)) + buffer-read-only) + (delete-region (gnus-point-at-bol) (progn (forward-line 1) (point))) + (gnus-insert-mime-button + handle id (list (not (mm-handle-displayed-p handle))))) + (mm-display-part handle)) + +(defun gnus-article-goto-part (n) + "Go to MIME part N." + (goto-char (text-property-any (point-min) (point-max) 'gnus-part n))) + +(defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed) (let ((gnus-tmp-name (mail-content-type-get (mm-handle-type handle) 'name)) (gnus-tmp-type (car (mm-handle-type handle))) (gnus-tmp-description (mm-handle-description handle)) + (gnus-tmp-dots + (if (if displayed (car displayed) + (mm-handle-displayed-p handle)) + "" "...")) + (gnus-tmp-length (save-excursion + (set-buffer (mm-handle-buffer handle)) + (buffer-size))) b e) (setq gnus-tmp-name - (if gnus-tmp-name - (concat " (" gnus-tmp-name ")") - "")) + (if gnus-tmp-name + (concat " (" gnus-tmp-name ")") + "")) (setq gnus-tmp-description - (if gnus-tmp-description - (concat " (" gnus-tmp-description ")") - "")) + (if gnus-tmp-description + (concat " (" gnus-tmp-description ")") + "")) (setq b (point)) (gnus-eval-format gnus-mime-button-line-format gnus-mime-button-line-format-alist `(local-map ,gnus-mime-button-map keymap ,gnus-mime-button-map - gnus-callback mm-display-part + gnus-callback gnus-mm-display-part + gnus-part ,gnus-tmp-id + gnus-type annotation gnus-data ,handle)) (setq e (point)) - (widget-convert-text 'link b e b e :action 'gnus-widget-press-button))) + (widget-convert-button 'link b e :action 'gnus-widget-press-button + :button-keymap gnus-mime-button-map))) (defun gnus-widget-press-button (elems el) (goto-char (widget-get elems :from)) - (gnus-article-press-button)) + (let ((url-standalone-mode (not gnus-plugged))) + (gnus-article-press-button))) (defun gnus-display-mime () "Insert MIME buttons in the buffer." @@ -2212,25 +2358,34 @@ If ALL-HEADERS is non-nil, no headers are hidden." (save-restriction (mail-narrow-to-head) (when (setq ct (mail-fetch-field "content-type")) - (setq ctl (mail-header-parse-content-type ct)))) + (setq ctl (condition-case () + (mail-header-parse-content-type ct) (error nil))))) (let* ((handles (mm-dissect-buffer)) - handle name type b e) + handle name type b e display) (mapcar 'mm-destroy-part gnus-article-mime-handles) - (setq gnus-article-mime-handles handles) + (setq gnus-article-mime-handles handles + gnus-article-mime-handle-alist nil) (when handles (goto-char (point-min)) (search-forward "\n\n" nil t) (delete-region (point) (point-max)) (if (not (equal (car ctl) "multipart/alternative")) (while (setq handle (pop handles)) - (gnus-insert-mime-button handle) - (insert "\n\n") - (when (and (mm-automatic-display-p (car (mm-handle-type handle))) + (setq display nil) + (when (and (mm-automatic-display-p + (car (mm-handle-type handle))) + (mm-inlinable-part-p (car (mm-handle-type handle))) (or (not (mm-handle-disposition handle)) (equal (car (mm-handle-disposition handle)) "inline"))) + (setq display t)) + (let ((id (1+ (length gnus-article-mime-handle-alist)))) + (push (cons id handle) gnus-article-mime-handle-alist) + (gnus-insert-mime-button handle id (list display))) + (insert "\n\n") + (when display (forward-line -2) - (mm-display-part handle) + (mm-display-part handle t) (goto-char (point-max)))) ;; Here we have multipart/alternative (gnus-mime-display-alternative handles)))))) @@ -2253,6 +2408,8 @@ If ALL-HEADERS is non-nil, no headers are hidden." (car (mm-handle-type handle)))) (point)) `(local-map ,gnus-mime-button-map + ,gnus-mouse-face-prop ,gnus-article-mouse-face + face ,gnus-article-button-face keymap ,gnus-mime-button-map gnus-callback (lambda (handles) @@ -2671,7 +2828,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)) - (buffer-disable-undo (current-buffer)) + (buffer-disable-undo) (setq major-mode 'gnus-original-article-mode) (setq buffer-read-only t)) (let (buffer-read-only) @@ -2680,8 +2837,10 @@ If given a prefix, show the hidden text instead." (setq gnus-original-article (cons group article))) ;; Decode charsets. - (run-hooks 'gnus-article-decode-hook)) - + (run-hooks 'gnus-article-decode-hook) + ;; Mark article as decoded or not. + (setq gnus-article-decoded-p gnus-article-decode-hook)) + ;; Update sparse articles. (when (and do-update-line (or (numberp article) @@ -2707,8 +2866,10 @@ If given a prefix, show the hidden text instead." (defvar gnus-article-edit-mode-map nil) +;; Should we be using derived.el for this? (unless gnus-article-edit-mode-map - (setq gnus-article-edit-mode-map (copy-keymap text-mode-map)) + (setq gnus-article-edit-mode-map (make-sparse-keymap)) + (set-keymap-parent gnus-article-edit-mode-map text-mode-map) (gnus-define-keys gnus-article-edit-mode-map "\C-c\C-c" gnus-article-edit-done @@ -2794,7 +2955,19 @@ groups." (save-excursion (set-buffer buf) (let ((buffer-read-only nil)) - (funcall func arg))) + (funcall func arg)) + ;; The cache and backlog have to be flushed somewhat. + (when gnus-keep-backlog + (gnus-backlog-remove-article + (car gnus-article-current) (cdr gnus-article-current))) + ;; Flush original article as well. + (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)))) (set-buffer buf) (set-window-start (get-buffer-window buf) start) (set-window-point (get-buffer-window buf) (point)))) @@ -2811,25 +2984,12 @@ groups." (insert buf) (let ((winconf gnus-prev-winconf)) (gnus-article-mode) - ;; The cache and backlog have to be flushed somewhat. - (when gnus-use-cache - (gnus-cache-update-article - (car gnus-article-current) (cdr gnus-article-current))) - (when gnus-keep-backlog - (gnus-backlog-remove-article - (car gnus-article-current) (cdr gnus-article-current))) - ;; Flush original article as well. - (save-excursion - (when (get-buffer gnus-original-article-buffer) - (set-buffer gnus-original-article-buffer) - (setq gnus-original-article nil))) (set-window-configuration winconf) ;; Tippy-toe some to make sure that point remains where it was. - (let ((buf (current-buffer))) + (save-current-buffer (set-buffer curbuf) (set-window-start (get-buffer-window (current-buffer)) window-start) - (goto-char p) - (set-buffer buf))))) + (goto-char p))))) (defun gnus-article-edit-full-stops () "Interactively repair spacing at end of sentences." @@ -2864,7 +3024,7 @@ groups." ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2 t gnus-button-message-id 3) ("\\( \n\t]+\\)>" 0 t gnus-url-mailto 2) - ("mailto:\\([a-zA-Z.-@_+0-9%]+\\)" 0 t gnus-url-mailto 1) + ("mailto:\\([-a-zA-Z.@_+0-9%]+\\)" 0 t gnus-url-mailto 1) ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1) ;; This is how URLs _should_ be embedded in text... ("]*\\)>" 0 t gnus-button-embedded-url 1) @@ -3137,8 +3297,8 @@ specified by `gnus-button-alist'." (list gnus-mouse-face-prop gnus-article-mouse-face)) (list 'gnus-callback fun) (and data (list 'gnus-data data)))) - (widget-convert-text 'link from to from to - :action 'gnus-widget-press-button)) + (widget-convert-button 'link from to :action 'gnus-widget-press-button + :button-keymap gnus-widget-button-keymap)) ;;; Internal functions: