X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;ds=sidebyside;f=lisp%2Fgnus-art.el;h=668f7b9e275d2673beccccdac5eccfefab0412a4;hb=b14ba71ca00ad909b738bad1898f1908c0e6d2eb;hp=6fb1f8456e42fde966570cfccdbe29ef58ef3d50;hpb=11800479556d89be98bf0af4f992e1337109f665;p=elisp%2Fgnus.git-

diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el
index 6fb1f84..668f7b9 100644
--- a/lisp/gnus-art.el
+++ b/lisp/gnus-art.el
@@ -95,7 +95,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:"
@@ -105,7 +105,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:"
@@ -556,8 +556,17 @@ displayed by the first non-nil matching CONTENT face."
   :group 'gnus-article-headers
   :type 'hook)
 
+(defcustom gnus-display-mime-function 'gnus-display-mime
+  "Function to display MIME articles."
+  :group 'gnus-article-headers
+  :type 'function)
+
+(defvar gnus-decode-header-function 'mail-decode-encoded-word-region
+  "Function used to decode headers.")
+
 ;;; Internal variables
 
+(defvar gnus-article-mime-handle-alist nil)
 (defvar article-lapsed-timer nil)
 (defvar gnus-article-current-summary nil)
 
@@ -958,8 +967,50 @@ characters to translate to."
 		  (process-send-region "article-x-face" beg end)
 		  (process-send-eof "article-x-face"))))))))))
 
-(defun gnus-article-decode-rfc1522 ()
-  "Decode MIME encoded-words in header fields."
+(defun article-decode-mime-words ()
+  "Decode all MIME-encoded words in the article."
+  (interactive)
+  (save-excursion
+    (set-buffer gnus-article-buffer)
+    (let ((inhibit-point-motion-hooks t)
+	  buffer-read-only)
+      (mail-decode-encoded-word-region (point-min) (point-max)))))
+
+(defun article-decode-charset (&optional prompt)
+  "Decode charset-encoded text in the article.
+If PROMPT (the prefix), prompt for a coding system to use."
+  (interactive "P")
+  (save-excursion
+    (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 ()
+			      (mail-header-parse-content-type ct)
+			    (error nil))))
+	     (charset (cond
+		       (prompt
+			(mm-read-coding-system "Charset to decode: "))
+		       (ctl
+			(mail-content-type-get ctl 'charset))
+		       (gnus-newsgroup-name
+			(gnus-group-find-parameter
+			 gnus-newsgroup-name 'charset))))
+	     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"))
+	  (mm-decode-body
+	   charset (and cte (intern (downcase
+				     (gnus-strip-whitespace cte))))))))))
+
+(defun article-decode-encoded-words ()
+  "Remove encoded-word encoding from headers."
   (let (buffer-read-only)
     (let ((charset (save-excursion
 		     (set-buffer gnus-summary-buffer)
@@ -967,6 +1018,24 @@ characters to translate to."
       (eword-decode-header charset)
       )))
 
+(defun article-de-quoted-unreadable (&optional force)
+  "Translate a quoted-printable-encoded article.
+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")))
+      (when (or force
+		(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))))))
+
+(defun article-mime-decode-quoted-printable-buffer ()
+  "Decode Quoted-Printable in the current buffer."
+  (quoted-printable-decode-region (point-min) (point-max)))
+
 (defun article-hide-pgp (&optional arg)
   "Toggle hiding of any PGP headers and signatures in the current article.
 If given a negative prefix, always show; if given a positive prefix,
@@ -1065,7 +1134,9 @@ always hide."
       (goto-char (point-min))
       (search-forward "\n\n" nil t)
       (while (re-search-forward "^[ \t]+$" nil t)
-	(replace-match "" nil t))
+	(unless (gnus-annotation-in-region-p
+		 (match-beginning 0) (match-end 0))
+	  (replace-match "" nil t)))
       ;; Then replace multiple empty lines with a single empty line.
       (goto-char (point-min))
       (search-forward "\n\n" nil t)
@@ -1395,11 +1466,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.
@@ -1485,7 +1558,7 @@ This format is defined by the `gnus-article-time-format' variable."
     (if (not gnus-default-article-saver)
 	(error "No default saver is defined")
       ;; !!! Magic!  The saving functions all save
-      ;; `gnus-original-article-buffer' (or so they think), but we
+      ;; `gnus-save-article-buffer' (or so they think), but we
       ;; bind that variable to our save-buffer.
       (set-buffer gnus-article-buffer)
       (let* ((gnus-save-article-buffer save-buffer)
@@ -1894,7 +1967,7 @@ commands:
   (make-local-variable 'gnus-button-marker-list)
   (make-local-variable 'gnus-article-current-summary)
   (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)
   (gnus-run-hooks 'gnus-article-mode-hook))
@@ -1909,6 +1982,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
@@ -1924,7 +1998,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))
@@ -2081,22 +2155,7 @@ If ALL-HEADERS is non-nil, no headers are hidden."
 		      (or all-headers gnus-show-all-headers))))
 	    (when (or (numberp article)
 		      (stringp article))
-	      (let ((method
-		     (if gnus-show-mime
-			 (progn
-			   (mime-parse-buffer)
-			   gnus-article-display-method-for-mime)
-		       gnus-article-display-method-for-traditional)))
-		;; Hooks for getting information from the article.
-		;; This hook must be called before being narrowed.
-		(gnus-run-hooks 'gnus-tmp-internal-hook)
-		(gnus-run-hooks 'gnus-article-prepare-hook)
-		;; Display message.
-		(funcall method)
-		;; Associate this article with the current summary buffer.
-		(setq gnus-article-current-summary summary-buffer)
-		;; 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
@@ -2110,6 +2169,219 @@ 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."
+  (let ((method (if gnus-show-mime
+		    (progn
+		      (mime-parse-buffer)
+		      gnus-article-display-method-for-mime)
+		  gnus-article-display-method-for-traditional)))
+    ;; Hooks for getting information from the article.
+    ;; This hook must be called before being narrowed.
+    (gnus-run-hooks 'gnus-tmp-internal-hook)
+    (gnus-run-hooks 'gnus-article-prepare-hook)
+    ;; Display message.
+    (funcall method)
+    ;; Associate this article with the current summary buffer.
+    (setq gnus-article-current-summary summary-buffer)
+    ;; Perform the article display hooks.
+    (gnus-run-hooks 'gnus-article-display-hook)))
+
+;;;
+;;; Gnus MIME viewing functions
+;;;
+
+(defvar gnus-mime-button-line-format "%{%([%p. %t%d%n]%)%}\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")
+
+(defvar gnus-mime-button-line-format-alist
+  '((?t gnus-tmp-type ?s)
+    (?n gnus-tmp-name ?s)
+    (?d gnus-tmp-description ?s)
+    (?p gnus-tmp-id ?s)
+    (?l gnus-tmp-length ?d)))
+
+(defvar gnus-mime-button-map nil)
+(unless gnus-mime-button-map
+  (setq gnus-mime-button-map (copy-keymap 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 "i" 'gnus-mime-inline-part)
+  (define-key gnus-mime-button-map "|" 'gnus-mime-pipe-part))
+
+(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."
+  (interactive)
+  (let ((data (get-text-property (point) 'gnus-data)))
+    (mm-save-part data)))
+
+(defun gnus-mime-pipe-part ()
+  "Pipe the MIME part under point to a process."
+  (interactive)
+  (let ((data (get-text-property (point) 'gnus-data)))
+    (mm-pipe-part data)))
+
+(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))
+	(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*"))
+    (insert contents)
+    (goto-char (point-min))))
+
+(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)
+      (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)
+  (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-length (save-excursion
+			   (set-buffer (mm-handle-buffer handle))
+			   (buffer-size)))
+	(gnus-tmp-id (1+ (length gnus-article-mime-handle-alist)))
+	b e)
+    (push (cons gnus-tmp-id handle) gnus-article-mime-handle-alist)
+    (setq gnus-tmp-name
+	  (if gnus-tmp-name
+	      (concat " (" gnus-tmp-name ")")
+	    ""))
+    (setq 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-part ,gnus-tmp-id
+		 gnus-type annotation
+		 gnus-data ,handle))
+    (setq e (point))
+    (widget-convert-button 'link from to :action 'gnus-widget-press-button
+			   :button-keymap gnus-widget-button-keymap)))
+
+(defun gnus-widget-press-button (elems el)
+  (goto-char (widget-get elems :from))
+  (let ((url-standalone-mode (not gnus-plugged)))
+    (gnus-article-press-button)))
+
+(defun gnus-display-mime ()
+  "Insert MIME buttons in the buffer."
+  (let (ct ctl)
+    (save-restriction
+      (mail-narrow-to-head)
+      (when (setq ct (mail-fetch-field "content-type"))
+	(setq ctl (condition-case ()
+		      (mail-header-parse-content-type ct) (error nil)))))
+    (let* ((handles (mm-dissect-buffer))
+	   handle name type b e)
+      (mapcar 'mm-destroy-part gnus-article-mime-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)))
+			 (mm-inlinable-part-p (car (mm-handle-type handle)))
+			 (or (not (mm-handle-disposition handle))
+			     (equal (car (mm-handle-disposition handle))
+				    "inline")))
+		(forward-line -2)
+		(mm-display-part handle t)
+		(goto-char (point-max))))
+	  ;; Here we have multipart/alternative
+	  (gnus-mime-display-alternative handles))))))
+
+(defun gnus-mime-display-alternative (handles &optional preferred)
+  (let* ((preferred (mm-preferred-alternative handles preferred))
+	 (ihandles handles)
+	 handle buffer-read-only)
+    (goto-char (point-min))
+    (search-forward "\n\n" nil t)
+    (delete-region (point) (point-max))
+    (mapcar 'mm-remove-part gnus-article-mime-handles)
+    (setq gnus-article-mime-handles handles)
+    (while (setq handle (pop handles))
+      (gnus-add-text-properties
+       (point)
+       (progn
+	 (insert (format "[%c] %-18s"
+			 (if (equal handle preferred) ?* ? )
+			 (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)
+		     (gnus-mime-display-alternative
+		      ',ihandles ,(car (mm-handle-type handle))))
+		   gnus-data ,handle))
+      (insert "  "))
+    (insert "\n\n")
+    (when preferred
+      (mm-display-part preferred))))
+
 (defun gnus-article-wash-status ()
   "Return a string which display status of article washing."
   (save-excursion
@@ -2510,17 +2782,19 @@ 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)
 	    (erase-buffer)
 	    (insert-buffer-substring gnus-article-buffer))
-	  (setq gnus-original-article (cons group article))))
+	  (setq gnus-original-article (cons group article)))
+
+	;; Decode charsets.
+	(run-hooks 'gnus-article-decode-hook)
+	;; Mark article as decoded or not.
+	(setq gnus-article-decoded-p gnus-article-decode-hook))
 
-      ;; Decode charsets.
-      (run-hooks 'gnus-article-decode-hook)
-      
       ;; Update sparse articles.
       (when (and do-update-line
 		 (or (numberp article)
@@ -2664,11 +2938,10 @@ groups."
 	  (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."
@@ -2703,7 +2976,7 @@ groups."
     ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2
      t gnus-button-message-id 3)
     ("\\(<URL: *\\)mailto: *\\([^> \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...
     ("<URL: *\\([^>]*\\)>" 0 t gnus-button-embedded-url 1)