+;;;###autoload
+(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
+ (funcall gnus-display-mime-function))))
+
+;;;
+;;; Gnus MIME viewing functions
+;;;
+
+(defvar gnus-mime-button-line-format "%{%([%p. %d%T]%)%}%e\n"
+ "The following specs can be used:
+%t The MIME type
+%T MIME type, along with additional info
+%n The `name' parameter
+%d The description, if any
+%l The length of the encoded part
+%p The part identifier number
+%e Dots if the part isn't displayed")
+
+(defvar gnus-mime-button-line-format-alist
+ '((?t gnus-tmp-type ?s)
+ (?T gnus-tmp-type-long ?s)
+ (?n gnus-tmp-name ?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 "v" "View Interactively...")
+ (gnus-mime-save-part "o" "Save...")
+ (gnus-mime-copy-part "c" "View As Text, In Other Buffer")
+ (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...")))
+
+(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))
+
+(defun gnus-mime-button-menu (event)
+ "Construct a context-sensitive menu of MIME commands."
+ (interactive "e")
+ (save-excursion
+ (let ((pos (event-start event)))
+ (set-buffer (window-buffer (posn-window pos)))
+ (goto-char (posn-point pos))
+ (gnus-article-check-buffer)
+ (let ((response (x-popup-menu
+ t `("MIME Part"
+ ("" ,@(mapcar (lambda (c)
+ (cons (caddr c) (car c)))
+ gnus-mime-button-commands))))))
+ (if response
+ (funcall response))))))
+
+(defun gnus-mime-view-all-parts (&optional handles)
+ "View all the MIME parts."
+ (interactive)
+ (save-current-buffer
+ (set-buffer gnus-article-buffer)
+ (let ((handles (or handles gnus-article-mime-handles))
+ (mail-parse-charset gnus-newsgroup-charset))
+ (if (stringp (car handles))
+ (gnus-mime-view-all-parts (cdr handles))
+ (mapcar 'mm-display-part handles)))))
+
+(defun gnus-mime-save-part ()
+ "Save the MIME part under point."
+ (interactive)
+ (gnus-article-check-buffer)
+ (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)
+ (gnus-article-check-buffer)
+ (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)
+ (gnus-article-check-buffer)
+ (let ((data (get-text-property (point) 'gnus-data)))
+ (mm-interactively-view-part data)))
+
+(defun gnus-mime-copy-part (&optional handle)
+ "Put the the MIME part under point into a new buffer."
+ (interactive)
+ (gnus-article-check-buffer)
+ (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
+ (contents (mm-get-part handle))|
+ (base (file-name-nondirectory
+ (or
+ (mail-content-type-get (mm-handle-type handle) 'name)
+ (mail-content-type-get (mm-handle-type handle)
+ 'filename)
+ "*decoded*")))
+ (buffer (generate-new-buffer base)))
+ (switch-to-buffer buffer)
+ (insert contents)
+ ;; We do it this way to make `normal-mode' set the appropriate mode.
+ (unwind-protect
+ (progn
+ (setq buffer-file-name (expand-file-name base))
+ (normal-mode))
+ (setq buffer-file-name nil))
+ (goto-char (point-min))))
+
+(defun gnus-mime-inline-part (&optional charset)
+ "Insert the MIME part under point into the current buffer."
+ (interactive "P") ; For compatibility reasons we are not using "z".
+ (gnus-article-check-buffer)
+ (let* ((data (get-text-property (point) 'gnus-data))
+ contents
+ (b (point))
+ buffer-read-only)
+ (if (mm-handle-undisplayer data)
+ (mm-remove-part data)
+ (setq contents (mm-get-part data))
+ (forward-line 2)
+ (when charset
+ (unless (symbolp charset)
+ (setq charset (mm-read-coding-system "Charset: ")))
+ (setq contents (mm-decode-coding-string contents charset)))
+ (mm-insert-inline data contents)
+ (goto-char b))))
+
+(defun gnus-mime-externalize-part (&optional handle)
+ "View the MIME part under point with an external viewer."
+ (interactive)
+ (gnus-article-check-buffer)
+ (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
+ (mm-user-display-methods nil)
+ (mm-all-images-fit t)
+ (mail-parse-charset gnus-newsgroup-charset))
+ (if (mm-handle-undisplayer handle)
+ (mm-remove-part handle)
+ (mm-display-part handle))))
+
+(defun gnus-mime-internalize-part (&optional handle)
+ "View the MIME part under point with an internal viewer."
+ (interactive)
+ (gnus-article-check-buffer)
+ (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
+ (mm-user-display-methods '((".*" . inline)))
+ (mm-all-images-fit t)
+ (mail-parse-charset gnus-newsgroup-charset))
+ (if (mm-handle-undisplayer handle)
+ (mm-remove-part handle)
+ (mm-display-part handle))))
+
+(defun gnus-article-part-wrapper (n function)
+ (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))))
+ (funcall function handle))))
+
+(defun gnus-article-pipe-part (n)
+ "Pipe MIME part N, which is the numerical prefix."
+ (interactive "p")
+ (gnus-article-part-wrapper n 'mm-pipe-part))
+
+(defun gnus-article-save-part (n)
+ "Save MIME part N, which is the numerical prefix."
+ (interactive "p")
+ (gnus-article-part-wrapper n 'mm-save-part))
+
+(defun gnus-article-interactively-view-part (n)
+ "Pipe MIME part N, which is the numerical prefix."
+ (interactive "p")
+ (gnus-article-part-wrapper n 'mm-interactively-view-part))
+
+(defun gnus-article-copy-part (n)
+ "Pipe MIME part N, which is the numerical prefix."
+ (interactive "p")
+ (gnus-article-part-wrapper n 'gnus-mime-copy-part))
+
+(defun gnus-article-externalize-part (n)
+ "Pipe MIME part N, which is the numerical prefix."
+ (interactive "p")
+ (gnus-article-part-wrapper n 'gnus-mime-externalize-part))
+
+(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))))
+ (when (gnus-article-goto-part n)
+ (if (equal (car handle) "multipart/alternative")
+ (gnus-article-press-button)
+ (when (eq (gnus-mm-display-part handle) 'internal)
+ (gnus-set-window-start)))))))
+
+(defun gnus-mm-display-part (handle)
+ "Display HANDLE and fix MIME button."
+ (let ((id (get-text-property (point) 'gnus-part))
+ (point (point))
+ buffer-read-only)
+ (forward-line 1)
+ (prog1
+ (let ((window (selected-window))
+ (mail-parse-charset gnus-newsgroup-charset))
+ (save-excursion
+ (unwind-protect
+ (let ((win (get-buffer-window (current-buffer) t))
+ (beg (point)))
+ (when win
+ (select-window win))
+ (goto-char point)
+ (forward-line)
+ (if (mm-handle-displayed-p handle)
+ ;; This will remove the part.
+ (mm-display-part handle)
+ (save-restriction
+ (narrow-to-region (point) (1+ (point)))
+ (mm-display-part handle)
+ (gnus-treat-article
+ nil id
+ (1- (length gnus-article-mime-handles))
+ (car (mm-handle-type handle))))))
+ (select-window window))))
+ (goto-char point)
+ (delete-region (gnus-point-at-bol) (progn (forward-line 1) (point)))
+ (gnus-insert-mime-button
+ handle id (list (mm-handle-displayed-p handle)))
+ (goto-char point))))
+
+(defun gnus-article-goto-part (n)
+ "Go to MIME part N."
+ (let ((point (text-property-any (point-min) (point-max) 'gnus-part n)))
+ (when point
+ (goto-char point))))
+
+(defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed)
+ (let ((gnus-tmp-name
+ (or (mail-content-type-get (mm-handle-type handle)
+ 'name)
+ (mail-content-type-get (mm-handle-disposition handle)
+ 'filename)
+ ""))
+ (gnus-tmp-type (car (mm-handle-type handle)))
+ (gnus-tmp-description
+ (mail-decode-encoded-word-string (or (mm-handle-description handle)
+ "")))
+ (gnus-tmp-dots
+ (if (if displayed (car displayed)
+ (mm-handle-displayed-p handle))
+ "" "..."))
+ (gnus-tmp-length (with-current-buffer (mm-handle-buffer handle)
+ (buffer-size)))
+ gnus-tmp-type-long b e)
+ (when (string-match ".*/" gnus-tmp-name)
+ (setq gnus-tmp-name (replace-match "" t t gnus-tmp-name)))
+ (setq gnus-tmp-type-long (concat gnus-tmp-type
+ (and (not (equal gnus-tmp-name ""))
+ (concat "; " gnus-tmp-name))))
+ (or (equal gnus-tmp-description "")
+ (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long)))
+ (unless (bolp)
+ (insert "\n"))
+ (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 gnus-mm-display-part
+ gnus-part ,gnus-tmp-id
+ 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"))))))
+
+(defun gnus-widget-press-button (elems el)
+ (goto-char (widget-get elems :from))
+ (gnus-article-press-button))
+
+(defun gnus-display-mime (&optional ihandles)
+ "Display the MIME parts."
+ (save-excursion
+ (save-selected-window
+ (let ((window (get-buffer-window gnus-article-buffer))
+ (point (point)))
+ (when window
+ (select-window window)
+ ;; We have to do this since selecting the window
+ ;; may change the point. So we set the window point.
+ (set-window-point window point)))
+ (let* ((handles (or ihandles (mm-dissect-buffer) (mm-uu-dissect)))
+ handle name type b e display)
+ (unless ihandles
+ ;; Top-level call; we clean up.
+ (mm-destroy-parts gnus-article-mime-handles)
+ (setq gnus-article-mime-handles handles
+ gnus-article-mime-handle-alist nil)
+ ;; We allow users to glean info from the handles.
+ (when gnus-article-mime-part-function
+ (gnus-mime-part-function handles)))
+ (if (and handles
+ (or (not (stringp (car handles)))
+ (cdr handles)))
+ (progn
+ (unless ihandles
+ ;; Clean up for mime parts.
+ (article-goto-body)
+ (delete-region (point) (point-max)))
+ (gnus-mime-display-part handles))
+ (save-restriction
+ (article-goto-body)
+ (narrow-to-region (point) (point-max))
+ (gnus-treat-article nil 1 1)))
+ ;; Highlight the headers.
+ (save-excursion
+ (save-restriction
+ (article-goto-body)
+ (narrow-to-region (point-min) (point))
+ (gnus-treat-article 'head)))))))
+
+(defvar gnus-mime-display-multipart-as-mixed nil)
+
+(defun gnus-mime-display-part (handle)
+ (cond
+ ;; Single part.
+ ((not (stringp (car handle)))
+ (gnus-mime-display-single handle))
+ ;; multipart/alternative
+ ((and (equal (car handle) "multipart/alternative")
+ (not gnus-mime-display-multipart-as-mixed))
+ (let ((id (1+ (length gnus-article-mime-handle-alist))))
+ (push (cons id handle) gnus-article-mime-handle-alist)
+ (gnus-mime-display-alternative (cdr handle) nil nil id)))
+ ;; multipart/related
+ ((and (equal (car handle) "multipart/related")
+ (not gnus-mime-display-multipart-as-mixed))
+ ;;;!!!We should find the start part, but we just default
+ ;;;!!!to the first part.
+ (gnus-mime-display-part (cadr handle)))
+ ;; Other multiparts are handled like multipart/mixed.
+ (t
+ (gnus-mime-display-mixed (cdr handle)))))
+
+(defun gnus-mime-part-function (handles)
+ (if (stringp (car handles))
+ (mapcar 'gnus-mime-part-function (cdr handles))
+ (funcall gnus-article-mime-part-function handles)))
+
+(defun gnus-mime-display-mixed (handles)
+ (mapcar 'gnus-mime-display-part handles))
+
+(defun gnus-mime-display-single (handle)
+ (let ((type (car (mm-handle-type handle)))
+ (ignored gnus-ignored-mime-types)
+ (not-attachment t)
+ (move nil)
+ display text)
+ (catch 'ignored
+ (progn
+ (while ignored
+ (when (string-match (pop ignored) type)
+ (throw 'ignored nil)))
+ (if (and (setq not-attachment
+ (or (not (mm-handle-disposition handle))
+ (equal (car (mm-handle-disposition handle))
+ "inline")
+ (mm-attachment-override-p type)))
+ (mm-automatic-display-p type)
+ (or (mm-inlinable-part-p type)
+ (mm-automatic-external-display-p type)))
+ (setq display t)
+ (when (equal (car (split-string type "/"))
+ "text")
+ (setq text t)))
+ (let ((id (1+ (length gnus-article-mime-handle-alist))))
+ (push (cons id handle) gnus-article-mime-handle-alist)
+ (when (or (not display)
+ (not (gnus-unbuttonized-mime-type-p type)))
+ (gnus-article-insert-newline)
+ (gnus-insert-mime-button
+ handle id (list (or display (and not-attachment text))))
+ (gnus-article-insert-newline)
+ (gnus-article-insert-newline)
+ (setq move t)))
+ (let ((beg (point)))
+ (cond
+ (display
+ (when move
+ (forward-line -2))
+ (let ((mail-parse-charset gnus-newsgroup-charset))
+ (mm-display-part handle t))
+ (goto-char (point-max)))
+ ((and text not-attachment)
+ (when move
+ (forward-line -2))
+ (gnus-article-insert-newline)
+ (mm-insert-inline handle (mm-get-part handle))
+ (goto-char (point-max))))
+ ;; Do highlighting.
+ (save-excursion
+ (save-restriction
+ (narrow-to-region beg (point))
+ (gnus-treat-article
+ nil (length gnus-article-mime-handle-alist)
+ (1- (length gnus-article-mime-handles))
+ (car (mm-handle-type handle))))))))))
+
+(defun gnus-unbuttonized-mime-type-p (type)
+ "Say whether TYPE is to be unbuttonized."
+ (unless gnus-inhibit-mime-unbuttonizing
+ (catch 'found
+ (let ((types gnus-unbuttonized-mime-types))
+ (while types
+ (when (string-match (pop types) type)
+ (throw 'found t)))))))
+
+(defun gnus-article-insert-newline ()
+ "Insert a newline, but mark it as undeletable."
+ (gnus-put-text-property
+ (point) (progn (insert "\n") (point)) 'gnus-undeletable t))
+
+(defun gnus-mime-display-alternative (handles &optional preferred ibegend id)
+ (let* ((preferred (or preferred (mm-preferred-alternative handles)))
+ (ihandles handles)
+ (point (point))
+ handle buffer-read-only from props begend not-pref)
+ (save-window-excursion
+ (save-restriction
+ (when ibegend
+ (narrow-to-region (car ibegend)
+ (or (cdr ibegend)
+ (progn
+ (goto-char (car ibegend))
+ (forward-line 2)
+ (point))))
+ (delete-region (point-min) (point-max))
+ (mm-remove-parts handles))
+ (setq begend (list (point-marker)))
+ ;; Do the toggle.
+ (unless (setq not-pref (cadr (member preferred ihandles)))
+ (setq not-pref (car ihandles)))
+ (when (or ibegend
+ (not (gnus-unbuttonized-mime-type-p
+ "multipart/alternative")))
+ (gnus-add-text-properties
+ (setq from (point))
+ (progn
+ (insert (format "%d. " id))
+ (point))
+ `(gnus-callback
+ (lambda (handles)
+ (unless ,(not ibegend)
+ (setq gnus-article-mime-handle-alist
+ ',gnus-article-mime-handle-alist))
+ (gnus-mime-display-alternative
+ ',ihandles ',not-pref ',begend ,id))
+ 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-part ,id
+ gnus-data ,handle))
+ (widget-convert-button 'link from (point)
+ :action 'gnus-widget-press-button
+ :button-keymap gnus-widget-button-keymap)
+ ;; Do the handles
+ (while (setq handle (pop handles))
+ (gnus-add-text-properties
+ (setq from (point))
+ (progn
+ (insert (format "(%c) %-18s"
+ (if (equal handle preferred) ?* ? )
+ (if (stringp (car handle))
+ (car handle)
+ (car (mm-handle-type handle)))))
+ (point))
+ `(gnus-callback
+ (lambda (handles)
+ (unless ,(not ibegend)
+ (setq gnus-article-mime-handle-alist
+ ',gnus-article-mime-handle-alist))
+ (gnus-mime-display-alternative
+ ',ihandles ',handle ',begend ,id))
+ 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-part ,id
+ gnus-data ,handle))
+ (widget-convert-button 'link from (point)
+ :action 'gnus-widget-press-button
+ :button-keymap gnus-widget-button-keymap)
+ (insert " "))
+ (insert "\n\n"))
+ (when preferred
+ (if (stringp (car preferred))
+ (gnus-display-mime preferred)
+ (let ((mail-parse-charset gnus-newsgroup-charset))
+ (mm-display-part preferred)))
+ (goto-char (point-max))
+ (setcdr begend (point-marker)))))
+ (when ibegend
+ (goto-char point))))
+