(max (1- b) (point-min))
b 'intangible (cddr (memq 'intangible props)))))
+(defmacro gnus-with-article (article &rest forms)
+ "Select ARTICLE and perform FORMS in the original article buffer.
+Then replace the article with the result."
+ `(progn
+ ;; We don't want the article to be marked as read.
+ (let (gnus-mark-article-hook)
+ (gnus-summary-select-article t t nil ,article))
+ (set-buffer gnus-original-article-buffer)
+ ,@forms
+ (if (not (gnus-check-backend-function
+ 'request-replace-article (car gnus-article-current)))
+ (gnus-message 5 "Read-only group; not replacing")
+ (unless (gnus-request-replace-article
+ ,article (car gnus-article-current)
+ (current-buffer) t)
+ (error "Couldn't replace article")))
+ ;; 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)))
+ (when gnus-use-cache
+ (gnus-cache-update-article
+ (car gnus-article-current) (cdr gnus-article-current)))))
+
+(put 'gnus-with-article 'lisp-indent-function 1)
+(put 'gnus-with-article 'edebug-form-spec '(form body))
+
(defsubst gnus-article-unhide-text (b e)
"Remove hidden text properties from region between B and E."
(remove-text-properties b e gnus-hidden-properties)
(point-max)))
'boring-headers))))
+(defvar gnus-article-normalized-header-length 40
+ "Length of normalized headers.")
+
+(defun article-normalize-headers ()
+ "Make all header lines 40 characters long."
+ (interactive)
+ (let ((buffer-read-only nil)
+ column)
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-head)
+ (while (not (eobp))
+ (cond
+ ((< (setq column (- (gnus-point-at-eol) (point)))
+ gnus-article-normalized-header-length)
+ (end-of-line)
+ (insert (make-string
+ (- gnus-article-normalized-header-length column)
+ ? )))
+ ((> column gnus-article-normalized-header-length)
+ (gnus-put-text-property
+ (progn
+ (forward-char gnus-article-normalized-header-length)
+ (point))
+ (gnus-point-at-eol)
+ 'invisible t))
+ (t
+ ;; Do nothing.
+ ))
+ (forward-line 1))))))
+
(defun article-treat-dumbquotes ()
- "Translate M******** sm*rtq**t*s into proper text."
+ "Translate M******** sm*rtq**t*s into proper text.
+Note that this function guesses whether a character is a sm*rtq**t* or
+not, so it should only be used interactively."
(interactive)
(article-translate-strings gnus-article-dumbquotes-map))
(defun article-decode-encoded-words ()
"Remove encoded-word encoding from headers."
(let ((inhibit-point-motion-hooks t)
- buffer-read-only
(rfc2047-default-charset gnus-newsgroup-default-charset)
- (mm-charset-iso-8859-1-forced gnus-newsgroup-iso-8859-1-forced))
+ (mm-charset-iso-8859-1-forced gnus-newsgroup-iso-8859-1-forced)
+ buffer-read-only)
(save-restriction
(message-narrow-to-head)
(funcall gnus-decode-header-function (point-min) (point-max)))))
article-date-lapsed
article-emphasize
article-treat-dumbquotes
+ article-normalize-headers
(article-show-all . gnus-article-show-all-headers))))
\f
;;;
(set-window-point (get-buffer-window (current-buffer)) (point))
t))))))
+;;;###autoload
(defun gnus-article-prepare-display ()
"Make the current buffer look like a nice article."
;; Hooks for getting information from the article.
(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)))
+ (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 "%{%([%p. %t%d%n]%)%}%e\n"
+(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
+%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)
(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 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...")))
(goto-char (posn-point pos))
(funcall response))))
-(defun gnus-mime-view-all-parts ()
+(defun gnus-mime-view-all-parts (&optional handles)
"View all the MIME parts."
(interactive)
(save-current-buffer
(set-buffer gnus-article-buffer)
- (let ((handles gnus-article-mime-handles)
+ (let ((handles (or handles gnus-article-mime-handles))
(rfc2047-default-charset gnus-newsgroup-default-charset)
(mm-charset-iso-8859-1-forced gnus-newsgroup-iso-8859-1-forced))
- (while handles
- (mm-display-part (pop handles))))))
+ (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."
"Interactively choose a view method for the MIME part under point."
(interactive)
(gnus-article-check-buffer)
- (let ((data (get-text-property (point) 'gnus-data))
- ;(url-standalone-mode (not gnus-plugged))
- )
+ (let ((data (get-text-property (point) 'gnus-data)))
(mm-interactively-view-part data)))
(defun gnus-mime-copy-part (&optional handle)
(interactive)
(gnus-article-check-buffer)
(let* ((handle (or 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*")))))
+ (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)
- (normal-mode)
+ ;; 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)
(interactive "P") ; For compatibility reasons we are not using "z".
(gnus-article-check-buffer)
(let* ((data (get-text-property (point) 'gnus-data))
- (contents (mm-get-part data))
- ;(url-standalone-mode (not gnus-plugged))
+ 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)
(goto-char b))))
(defun gnus-mime-externalize-part (&optional handle)
- "Insert the MIME part under point into the current buffer."
+ "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)))
- ;(url-standalone-mode (not gnus-plugged))
(mm-user-display-methods nil)
+ (mm-all-images-fit t)
+ (rfc2047-default-charset gnus-newsgroup-default-charset)
+ (mm-charset-iso-8859-1-forced gnus-newsgroup-iso-8859-1-forced))
+ (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)
(rfc2047-default-charset gnus-newsgroup-default-charset)
(mm-charset-iso-8859-1-forced gnus-newsgroup-iso-8859-1-forced))
(if (mm-handle-undisplayer handle)
(goto-char point))))
(defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed)
- (let ((gnus-tmp-name (mail-content-type-get (mm-handle-type handle) 'name))
+ (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 (mm-handle-description 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 (save-excursion
- (set-buffer (mm-handle-buffer handle))
+ (gnus-tmp-length (with-current-buffer (mm-handle-buffer handle)
(buffer-size)))
- b e)
- (setq gnus-tmp-name
- (if gnus-tmp-name
- (concat " (" gnus-tmp-name ")")
- ""))
- (setq gnus-tmp-description
- (if gnus-tmp-description
- (concat " (" gnus-tmp-description ")")
- ""))
+ 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))
article-type annotation
gnus-data ,handle))
(setq e (point))
- (widget-convert-button 'link b e :action 'gnus-widget-press-button
- :button-keymap gnus-mime-button-map)))
+ (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))
- (let ((url-standalone-mode (not gnus-plugged)))
- (gnus-article-press-button)))
+ (gnus-article-press-button))
(defun gnus-display-mime (&optional ihandles)
"Insert MIME buttons in the buffer."
(save-excursion
(save-selected-window
- (let ((window (get-buffer-window gnus-article-buffer)))
+ (let ((window (get-buffer-window gnus-article-buffer))
+ (point (point)))
(when window
- (select-window 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
(delete-region (point) (point-max)))
(gnus-mime-display-part handles))))))
+(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
- ((equal (car 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
- ((equal (car handle) "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)))
(funcall gnus-article-mime-part-function handles)))
(defun gnus-mime-display-mixed (handles)
- (let (handle)
- (while (setq handle (pop handles))
- (gnus-mime-display-part handle))))
+ (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 (mm-automatic-display-p type)
- (mm-inlinable-part-p type)
- (setq not-attachment
+ (if (and (setq not-attachment
(or (not (mm-handle-disposition handle))
(equal (car (mm-handle-disposition handle))
- "inline"))))
+ "inline")))
+ (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")
(gnus-article-insert-newline)
(gnus-insert-mime-button
handle id (list (or display
- (and (not not-attachment) text))))
- (gnus-article-insert-newline)))
- (gnus-article-insert-newline)
+ (and not-attachment text))))
+ (gnus-article-insert-newline)
+ (gnus-article-insert-newline)
+ (setq move t)))
(cond
(display
- (forward-line -2)
+ (when move
+ (forward-line -2))
(let ((rfc2047-default-charset gnus-newsgroup-default-charset)
(mm-charset-iso-8859-1-forced
gnus-newsgroup-iso-8859-1-forced))
(mm-display-part handle t))
(goto-char (point-max)))
((and text not-attachment)
- (forward-line -2)
+ (when move
+ (forward-line -2))
(gnus-article-insert-newline)
(mm-insert-inline handle (mm-get-part handle))
(goto-char (point-max))))))))
(gnus-add-text-properties
(setq from (point))
(progn
- (insert (format "[%c] %-18s"
+ (insert (format "(%c) %-18s"
(if (equal handle preferred) ?* ? )
(if (stringp (car handle))
(car handle)
(select-window win)))
(defvar gnus-decode-header-methods
- '(gnus-decode-with-mail-decode-encoded-word-region)
- "List of methods used to decode headers
+ '(mail-decode-encoded-word-region)
+ "List of methods used to decode headers.
This variable is a list of FUNCTION or (REGEXP . FUNCTION). If item is
FUNCTION, FUNCTION will be apply to all newsgroups. If item is a
(defvar gnus-decode-header-methods-cache nil)
-(defun gnus-decode-with-mail-decode-encoded-word-region (start end)
- (let ((rfc2047-default-charset gnus-default-charset))
- (mail-decode-encoded-word-region start end)))
-
(defun gnus-multi-decode-header (start end)
"Apply the functions from `gnus-encoded-word-methods' that match."
(unless (and gnus-decode-header-methods-cache
projects / elisp / gnus.git- / blobdiff