(require 'gnus-spec)
(require 'gnus-int)
(require 'browse-url)
+(require 'mm-bodies)
(defgroup gnus-article nil
"Article display."
:group 'gnus-article)
(defcustom gnus-ignored-headers
- '("^Path:" "^Posting-Version:" "^Article-I.D.:" "^Expires:"
- "^Date-Received:" "^References:" "^Control:" "^Xref:" "^Lines:"
- "^Posted:" "^Relay-Version:" "^Message-ID:" "^Nf-ID:" "^Nf-From:"
- "^Approved:" "^Sender:" "^Received:" "^Mail-from:")
+ '("^Path:" "^Expires:" "^Date-Received:" "^References:" "^Xref:" "^Lines:"
+ "^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:"
+ "^X-Authentication-Warning:" "^X-MIME-Autoconverted:" "^X-Face:"
+ "^X-Attribution:" "^X-Originating-IP:" "^Delivered-To:"
+ "^NNTP-[-A-Za-z]+:" "^Distribution:" "^X-no-archive:" "^X-Trace:"
+ "^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:"
+ "^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:"
+ "^X-Pgp-Public-Key-Url:" "^X-Auth:" "^X-From-Line:"
+ "^X-Gnus-Article-Number:" "^X-Majordomo:" "^X-Url:" "^X-Sender:"
+ "^X-Mailing-List:" "^MBOX-Line" "^Priority:" "^X-Pgp" "^X400-[-A-Za-z]+:"
+ "^Status:")
"*All headers that start with this regexp will be hidden.
This variable can also be a list of regexps of headers to be ignored.
If `gnus-visible-headers' is non-nil, this variable will be ignored."
:group 'gnus-article-washing)
(eval-and-compile
- (autoload 'hexl-hex-string-to-integer "hexl")
- (autoload 'timezone-make-date-arpa-standard "timezone")
(autoload 'mail-extract-address-components "mail-extr"))
(defcustom gnus-save-all-headers t
:type 'regexp
:group 'gnus-article-various)
-(defcustom gnus-article-mode-line-format "Gnus: %%b %S"
+(defcustom gnus-article-mode-line-format "Gnus: %g %S"
"*The format specification for the article mode line.
See `gnus-summary-mode-line-format' for a closer description."
:type 'string
(listp gnus-visible-headers))
(mapconcat 'identity gnus-visible-headers "\\|"))))
(inhibit-point-motion-hooks t)
- want-list beg)
+ beg)
;; First we narrow to just the headers.
(widen)
(goto-char (point-min))
((eq elem 'date)
(let ((date (message-fetch-field "date")))
(when (and date
- (< (gnus-days-between (current-time-string) date)
+ (< (days-between (current-time-string) date)
4))
(gnus-article-hide-header "date"))))
((eq elem 'long-to)
(delete-process "article-x-face"))
(let ((inhibit-point-motion-hooks t)
(case-fold-search t)
- from)
+ from last)
(save-restriction
(nnheader-narrow-to-headers)
(setq from (message-fetch-field "from"))
(goto-char (point-min))
- ;; This used to try to do multiple faces (`while' instead of
- ;; `when' below), but (a) sending multiple EOFs to xv doesn't
- ;; work (b) it can crash some versions of Emacs (c) are
- ;; multiple faces really something to encourage?
- (when (and gnus-article-x-face-command
- (or force
- ;; Check whether this face is censored.
- (not gnus-article-x-face-too-ugly)
- (and gnus-article-x-face-too-ugly from
- (not (string-match gnus-article-x-face-too-ugly
- from))))
- ;; Has to be present.
- (re-search-forward "^X-Face: " nil t))
+ (while (and gnus-article-x-face-command
+ (not last)
+ (or force
+ ;; Check whether this face is censored.
+ (not gnus-article-x-face-too-ugly)
+ (and gnus-article-x-face-too-ugly from
+ (not (string-match gnus-article-x-face-too-ugly
+ from))))
+ ;; Has to be present.
+ (re-search-forward "^X-Face: " nil t))
+ ;; This used to try to do multiple faces (`while' instead of
+ ;; `when' above), but (a) sending multiple EOFs to xv doesn't
+ ;; work (b) it can crash some versions of Emacs (c) are
+ ;; multiple faces really something to encourage?
+ (when (stringp gnus-article-x-face-command)
+ (setq last t))
;; We now have the area of the buffer where the X-Face is stored.
(save-excursion
(let ((beg (point))
(process-send-region "article-x-face" beg end)
(process-send-eof "article-x-face"))))))))))
-(defun gnus-hack-decode-rfc1522 ()
- "Emergency hack function for avoiding problems when decoding."
- (let ((buffer-read-only nil))
- (goto-char (point-min))
- ;; Remove encoded TABs.
- (while (search-forward "=09" nil t)
- (replace-match " " t t))
- ;; Remove encoded newlines.
- (goto-char (point-min))
- (while (search-forward "=10" nil t)
- (replace-match " " t t))))
+(defun gnus-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)
+ (rfc2047-decode-region (point-min) (point-max)))))
+
+(defun gnus-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
+ (set-buffer gnus-article-buffer)
+ (save-restriction
+ (message-narrow-to-head)
+ (let* ((inhibit-point-motion-hooks t)
+ (ct (message-fetch-field "Content-Type" t))
+ (cte (message-fetch-field "Content-Transfer-Encoding" t))
+ (charset (cond
+ (prompt
+ (mm-read-coding-system "Charset to decode: "))
+ (ct
+ (mm-content-type-charset ct))
+ (gnus-newsgroup-name
+ (gnus-group-find-parameter
+ gnus-newsgroup-name 'charset))))
+ buffer-read-only)
+ (goto-char (point-max))
+ (widen)
+ (narrow-to-region (point) (point-max))
+ (mm-decode-body
+ charset (and cte (intern (downcase (gnus-strip-whitespace cte)))))))))
(defalias 'gnus-decode-rfc1522 'article-decode-rfc1522)
(defalias 'gnus-article-decode-rfc1522 'article-decode-rfc1522)
(defun article-decode-rfc1522 ()
- "Hack to remove QP encoding from headers."
- (let ((case-fold-search t)
- (inhibit-point-motion-hooks t)
- (buffer-read-only nil)
- string)
+ "Remove QP encoding from headers."
+ (let ((inhibit-point-motion-hooks t)
+ (buffer-read-only nil))
(save-restriction
- (narrow-to-region
- (goto-char (point-min))
- (or (search-forward "\n\n" nil t) (point-max)))
- (goto-char (point-min))
- (while (re-search-forward
- "=\\?iso-8859-1\\?q\\?\\([^?\t\n]*\\)\\?=" nil t)
- (setq string (match-string 1))
- (save-restriction
- (narrow-to-region (match-beginning 0) (match-end 0))
- (delete-region (point-min) (point-max))
- (insert string)
- (article-mime-decode-quoted-printable
- (goto-char (point-min)) (point-max))
- (subst-char-in-region (point-min) (point-max) ?_ ? )
- (goto-char (point-max)))
- (goto-char (point-min))))))
+ (message-narrow-to-head)
+ (rfc2047-decode-region (point-min) (point-max)))))
(defun article-de-quoted-unreadable (&optional force)
- "Do a naive translation of a quoted-printable-encoded article.
-This is in no way, shape or form meant as a replacement for real MIME
-processing, but is simply a stop-gap measure until MIME support is
-written.
+ "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 ((case-fold-search t)
- (buffer-read-only nil)
+ (let ((buffer-read-only nil)
(type (gnus-fetch-field "content-transfer-encoding")))
(gnus-article-decode-rfc1522)
(when (or force
(and type (string-match "quoted-printable" (downcase type))))
(goto-char (point-min))
(search-forward "\n\n" nil 'move)
- (article-mime-decode-quoted-printable (point) (point-max))))))
+ (quoted-printable-decode-region (point) (point-max))))))
(defun article-mime-decode-quoted-printable-buffer ()
"Decode Quoted-Printable in the current buffer."
- (article-mime-decode-quoted-printable (point-min) (point-max)))
-
-(defun article-mime-decode-quoted-printable (from to)
- "Decode Quoted-Printable in the region between FROM and TO."
- (interactive "r")
- (goto-char from)
- (while (search-forward "=" to t)
- (cond ((eq (following-char) ?\n)
- (delete-char -1)
- (delete-char 1))
- ((looking-at "[0-9A-F][0-9A-F]")
- (subst-char-in-region
- (1- (point)) (point) ?=
- (hexl-hex-string-to-integer
- (buffer-substring (point) (+ 2 (point)))))
- (delete-char 2))
- ((looking-at "=")
- (delete-char 1))
- ((gnus-message 3 "Malformed MIME quoted-printable message")))))
+ (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.
(setq b (point))
(point-max))
(setq e (point-max)))
- (nnheader-temp-write nil
+ (with-temp-buffer
(insert-buffer-substring gnus-article-buffer b e)
(require 'url)
(save-window-excursion
(defun gnus-article-hidden-text-p (type)
"Say whether the current buffer contains hidden text of type TYPE."
- (let ((start (point-min))
- (pos (text-property-any (point-min) (point-max) 'article-type type)))
+ (let ((pos (text-property-any (point-min) (point-max) 'article-type type)))
(while (and pos
(not (get-text-property pos 'invisible)))
(setq pos
;; functions since they aren't particularly resistant to
;; buggy dates.
((eq type 'local)
- (concat "Date: " (condition-case ()
- (timezone-make-date-arpa-standard date)
- (error date))))
+ (concat "Date: " (current-time-string (date-to-time date))))
;; Convert to Universal Time.
((eq type 'ut)
(concat "Date: "
- (condition-case ()
- (timezone-make-date-arpa-standard date nil "UT")
- (error date))))
+ (current-time-string
+ (let ((e (parse-time-string date)))
+ (setcar (last e) 0)
+ (encode-time e)))))
;; Get the original date from the article.
((eq type 'original)
(concat "Date: " date))
;; Let the user define the format.
((eq type 'user)
(if (gnus-functionp gnus-article-time-format)
- (funcall
- gnus-article-time-format
- (ignore-errors
- (gnus-encode-date
- (timezone-make-date-arpa-standard
- date nil "UT"))))
+ (funcall gnus-article-time-format (date-to-time date))
(concat
"Date: "
- (format-time-string gnus-article-time-format
- (ignore-errors
- (gnus-encode-date
- (timezone-make-date-arpa-standard
- date nil "UT")))))))
+ (format-time-string gnus-article-time-format (date-to-time date)))))
;; ISO 8601.
((eq type 'iso8601)
(concat
"Date: "
- (format-time-string "%Y%M%DT%h%m%s"
- (ignore-errors
- (gnus-encode-date
- (timezone-make-date-arpa-standard
- date nil "UT"))))))
+ (format-time-string "%Y%M%DT%h%m%s" (date-to-time date))))
;; Do an X-Sent lapsed format.
((eq type 'lapsed)
;; If the date is seriously mangled, the timezone functions are
;; liable to bug out, so we ignore all errors.
(let* ((now (current-time))
- (real-time
- (ignore-errors
- (gnus-time-minus
- (gnus-encode-date
- (timezone-make-date-arpa-standard
- (current-time-string now)
- (current-time-zone now) "UT"))
- (gnus-encode-date
- (timezone-make-date-arpa-standard
- date nil "UT")))))
+ (real-time (subtract-time now (date-to-time date)))
(real-sec (and real-time
(+ (* (float (car real-time)) 65536)
(cadr real-time))))
(save-excursion
(save-restriction
(widen)
- (gnus-output-to-rmail filename))))
+ (rmail-output-to-rmail-file filename))))
filename)
(defun gnus-summary-save-in-mail (&optional filename)
(widen)
(if (and (file-readable-p filename)
(mail-file-babyl-p filename))
- (gnus-output-to-rmail filename t)
+ (rmail-output-to-rmail-file filename t)
(gnus-output-to-mail filename)))))
filename)
(buffer-disable-undo (current-buffer))
(setq buffer-read-only t)
(set-syntax-table gnus-article-mode-syntax-table)
+ (mm-enable-multibyte)
(gnus-run-hooks 'gnus-article-mode-hook))
(defun gnus-article-setup-buffer ()
(gnus-set-global-variables)))
;; Init original article buffer.
(save-excursion
- (set-buffer (get-buffer-create gnus-original-article-buffer))
+ (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
(buffer-disable-undo (current-buffer))
(setq major-mode 'gnus-original-article-mode)
- (gnus-add-current-to-buffer-list)
(make-local-variable 'gnus-original-article))
(if (get-buffer name)
(save-excursion
(set-buffer name)
(buffer-disable-undo (current-buffer))
(setq buffer-read-only t)
- (gnus-add-current-to-buffer-list)
(unless (eq major-mode 'gnus-article-mode)
(gnus-article-mode))
(current-buffer))
(save-excursion
- (set-buffer (get-buffer-create name))
- (gnus-add-current-to-buffer-list)
+ (set-buffer (gnus-get-buffer-create name))
(gnus-article-mode)
(make-local-variable 'gnus-summary-buffer)
(current-buffer)))))
(setq gnus-summary-buffer (current-buffer))
(let* ((gnus-article (if header (mail-header-number header) article))
(summary-buffer (current-buffer))
- (internal-hook gnus-article-internal-prepare-hook)
+ (gnus-tmp-internal-hook gnus-article-internal-prepare-hook)
(group gnus-newsgroup-name)
result)
(save-excursion
(unless (memq article gnus-newsgroup-sparse)
(gnus-error 1
"No such article (may have expired or been canceled)")))))
- (if (or (eq result 'pseudo) (eq result 'nneething))
+ (if (or (eq result 'pseudo)
+ (eq result 'nneething))
(progn
(save-excursion
(set-buffer summary-buffer)
;; Hooks for getting information from the article.
;; This hook must be called before being narrowed.
(let (buffer-read-only)
- (gnus-run-hooks 'internal-hook)
+ (gnus-run-hooks 'gnus-tmp-internal-hook)
(gnus-run-hooks 'gnus-article-prepare-hook)
;; Decode MIME message.
(when gnus-show-mime
(defun gnus-output-to-file (file-name)
"Append the current article to a file named FILE-NAME."
(let ((artbuf (current-buffer)))
- (nnheader-temp-write nil
+ (with-temp-buffer
(insert-buffer-substring artbuf)
;; Append newline at end of the buffer as separator, and then
;; save it to file.
gnus-newsgroup-name)))
(when (and (eq (car method) 'nneething)
(vectorp header))
- (let ((dir (concat (file-name-as-directory (nth 1 method))
- (mail-header-subject header))))
+ (let ((dir (concat
+ (file-name-as-directory
+ (or (cadr (assq 'nneething-address method))
+ (nth 1 method)))
+ (mail-header-subject header))))
(when (file-directory-p dir)
(setq article 'nneething)
(gnus-group-enter-directory dir))))))))
(save-excursion
(if (get-buffer gnus-original-article-buffer)
(set-buffer gnus-original-article-buffer)
- (set-buffer (get-buffer-create gnus-original-article-buffer))
+ (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
(buffer-disable-undo (current-buffer))
(setq major-mode 'gnus-original-article-mode)
- (setq buffer-read-only t)
- (gnus-add-current-to-buffer-list))
+ (setq buffer-read-only t))
(let (buffer-read-only)
(erase-buffer)
(insert-buffer-substring gnus-article-buffer))
(let* ((pos (posn-point (event-start event)))
(data (get-text-property pos 'gnus-data))
(fun (get-text-property pos 'gnus-callback)))
+ (goto-char pos)
(when fun
(funcall fun data))))
(defun gnus-url-parse-query-string (query &optional downcase)
(let (retval pairs cur key val)
- (setq pairs (gnus-split-string query "&"))
+ (setq pairs (split-string query "&"))
(while pairs
(setq cur (car pairs)
pairs (cdr pairs))
;; Send mail to someone
(when (string-match "mailto:/*\\(.*\\)" url)
(setq url (substring url (match-beginning 1) nil)))
- (let (to args source-url subject func)
+ (let (to args subject func)
(if (string-match (regexp-quote "?") url)
(setq to (gnus-url-unhex-string (substring url 0 (match-beginning 0)))
args (gnus-url-parse-query-string
projects / gnus / blobdiff