;;; Code:
+(eval-when-compile (require 'cl))
+
(require 'custom)
(require 'gnus)
(require 'gnus-sum)
"^Date-Received:" "^References:" "^Control:" "^Xref:" "^Lines:"
"^Posted:" "^Relay-Version:" "^Message-ID:" "^Nf-ID:" "^Nf-From:"
"^Approved:" "^Sender:" "^Received:" "^Mail-from:")
- "All headers that match this regexp will be hidden.
+ "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."
:type '(choice :custom-show nil
:group 'gnus-article-hiding)
(defcustom gnus-visible-headers
- "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From"
+ "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|X-Sent:"
"All headers that do not match this regexp will be hidden.
This variable can also be a list of regexp of headers to remain visible.
If this variable is non-nil, `gnus-ignored-headers' will be ignored."
(defcustom gnus-boring-article-headers '(empty followup-to reply-to)
"Headers that are only to be displayed if they have interesting data.
Possible values in this list are `empty', `newsgroups', `followup-to',
-`reply-to', and `date'."
+`reply-to', `date', `long-to', and `many-to'."
:type '(set (const :tag "Headers with no content." empty)
(const :tag "Newsgroups with only one group." newsgroups)
(const :tag "Followup-to identical to newsgroups." followup-to)
(const :tag "Reply-to identical to from." reply-to)
- (const :tag "Date less than four days old." date))
+ (const :tag "Date less than four days old." date)
+ (const :tag "Very long To header." long-to)
+ (const :tag "Multiple To headers." many-to))
:group 'gnus-article-hiding)
(defcustom gnus-signature-separator '("^-- $" "^-- *$")
(defcustom gnus-article-x-face-too-ugly nil
"Regexp matching posters whose face shouldn't be shown automatically."
- :type 'regexp
+ :type '(choice regexp (const nil))
:group 'gnus-article-washing)
(defcustom gnus-emphasis-alist
(defcustom gnus-article-time-format "%a, %b %d %Y %T %Z"
"Format for display of Date headers in article bodies.
-See `format-time-zone' for the possible values."
+See `format-time-string' for the possible values."
:type 'string
:link '(custom-manual "(gnus)Article Date")
:group 'gnus-article-washing)
If that variable is nil, however, all headers that match this regexp
will be kept while the rest will be deleted before saving."
:group 'gnus-article-saving
- :type '(repeat string))
+ :type 'regexp)
(defcustom gnus-default-article-saver 'gnus-summary-save-in-rmail
"A function to save articles in your favourite format.
;;; Internal variables
+(defvar article-lapsed-timer nil)
+
(defvar gnus-article-mode-syntax-table
(let ((table (copy-syntax-table text-mode-syntax-table)))
(modify-syntax-entry ?- "w" table)
(let ((b (point-min)))
(while (setq b (text-property-any b (point-max) 'article-type type))
(delete-region
- b (text-property-not-all b (point-max) 'article-type type))))))
+ b (or (text-property-not-all b (point-max) 'article-type type)
+ (point-max)))))))
(defun gnus-article-delete-invisible-text ()
"Delete all invisible text in the current buffer."
(let ((b (point-min)))
(while (setq b (text-property-any b (point-max) 'invisible t))
(delete-region
- b (text-property-not-all b (point-max) 'invisible t))))))
+ b (or (text-property-not-all b (point-max) 'invisible t)
+ (point-max)))))))
(defun gnus-article-text-type-exists-p (type)
"Say whether any text of type TYPE exists in the buffer."
If given a negative prefix, always show; if given a positive prefix,
always hide."
(interactive (gnus-article-hidden-arg))
+ (current-buffer)
(if (gnus-article-check-hidden-text 'headers arg)
;; Show boring headers as well.
(gnus-article-show-hidden-text 'boring-headers)
(when (and date
(< (gnus-days-between (current-time-string) date)
4))
- (gnus-article-hide-header "date")))))))))))
+ (gnus-article-hide-header "date"))))
+ ((eq elem 'long-to)
+ (let ((to (message-fetch-field "to")))
+ (when (> (length to) 1024)
+ (gnus-article-hide-header "to"))))
+ ((eq elem 'many-to)
+ (let ((to-count 0))
+ (goto-char (point-min))
+ (while (re-search-forward "^to:" nil t)
+ (setq to-count (1+ to-count)))
+ (when (> to-count 1)
+ (while (> to-count 0)
+ (goto-char (point-min))
+ (save-restriction
+ (re-search-forward "^to:" nil nil to-count)
+ (forward-line -1)
+ (narrow-to-region (point) (point-max))
+ (gnus-article-hide-header "to"))
+ (setq to-count (1- to-count)))))))))))))
(defun gnus-article-hide-header (header)
(save-excursion
(point-max)))
'boring-headers))))
-;; Written by Per Abrahamsen <amanda@iesd.auc.dk>.
+(defun article-treat-dumbquotes ()
+ "Translate M******** sm*rtq**t*s into proper text."
+ (interactive)
+ (article-translate-characters "\221\222\223\223" "`'\"\""))
+
+(defun article-translate-characters (from to)
+ "Translate all characters in the body of the article according to FROM and TO.
+FROM is a string of characters to translate from; to is a string of
+characters to translate to."
+ (save-excursion
+ (goto-char (point-min))
+ (when (search-forward "\n\n" nil t)
+ (let ((buffer-read-only nil)
+ (x (make-string 225 ?x))
+ (i -1))
+ (while (< (incf i) (length x))
+ (aset x i i))
+ (setq i 0)
+ (while (< i (length from))
+ (aset x (aref from i) (aref to i))
+ (incf i))
+ (translate-region (point) (point-max) x)))))
+
(defun article-treat-overstrike ()
"Translate overstrikes into bold text."
(interactive)
(when (process-status "article-x-face")
(delete-process "article-x-face"))
(let ((inhibit-point-motion-hooks t)
- (case-fold-search nil)
+ (case-fold-search t)
from)
(save-restriction
(nnheader-narrow-to-headers)
;; Hide the "header".
(when (search-forward "\n-----BEGIN PGP SIGNED MESSAGE-----\n" nil t)
(gnus-article-hide-text-type (1+ (match-beginning 0))
- (match-end 0) 'pgp))
- (setq beg (point))
- ;; Hide the actual signature.
- (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t)
- (setq end (1+ (match-beginning 0)))
- (gnus-article-hide-text-type
- end
- (if (search-forward "\n-----END PGP SIGNATURE-----\n" nil t)
- (match-end 0)
- ;; Perhaps we shouldn't hide to the end of the buffer
- ;; if there is no end to the signature?
- (point-max))
- 'pgp))
- ;; Hide "- " PGP quotation markers.
- (when (and beg end)
- (narrow-to-region beg end)
- (goto-char (point-min))
- (while (re-search-forward "^- " nil t)
- (gnus-article-hide-text-type
- (match-beginning 0) (match-end 0) 'pgp))
- (widen)))
- (run-hooks 'gnus-article-hide-pgp-hook))))
+ (match-end 0) 'pgp)
+ (setq beg (point))
+ ;; Hide the actual signature.
+ (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t)
+ (setq end (1+ (match-beginning 0)))
+ (gnus-article-hide-text-type
+ end
+ (if (search-forward "\n-----END PGP SIGNATURE-----\n" nil t)
+ (match-end 0)
+ ;; Perhaps we shouldn't hide to the end of the buffer
+ ;; if there is no end to the signature?
+ (point-max))
+ 'pgp))
+ ;; Hide "- " PGP quotation markers.
+ (when (and beg end)
+ (narrow-to-region beg end)
+ (goto-char (point-min))
+ (while (re-search-forward "^- " nil t)
+ (gnus-article-hide-text-type
+ (match-beginning 0) (match-end 0) 'pgp))
+ (widen))
+ (run-hooks 'gnus-article-hide-pgp-hook))))))
(defun article-hide-pem (&optional arg)
"Toggle hiding of any PEM headers and signatures in the current article.
nil)))
(eval-and-compile
- (autoload 'w3-parse-buffer "w3-parse"))
+ (autoload 'w3-display "w3-parse")
+ (autoload 'w3-do-setup "w3" "" t)
+ (autoload 'w3-region "w3-display" "" t))
(defun gnus-article-treat-html ()
"Render HTML."
(let ((cbuf (current-buffer)))
(set-buffer gnus-article-buffer)
(let (buf buffer-read-only b e)
+ (w3-do-setup)
(goto-char (point-min))
(narrow-to-region
(if (search-forward "\n\n" nil t)
(insert-buffer-substring gnus-article-buffer b e)
(require 'url)
(save-window-excursion
- (w3-parse-buffer (current-buffer))
- (setq buf (buffer-string))))
+ (w3-region (point-min) (point-max))
+ (setq buf (buffer-substring-no-properties (point-min) (point-max)))))
(when buf
(delete-region (point-min) (point-max))
(insert buf))
header))
(date-regexp "^Date:[ \t]\\|^X-Sent:[ \t]")
(inhibit-point-motion-hooks t)
- bface eface)
+ bface eface newline)
(when (and date (not (string= date "")))
(save-excursion
(save-restriction
(setq bface (get-text-property (gnus-point-at-bol) 'face)
eface (get-text-property (1- (gnus-point-at-eol))
'face))
- (message-remove-header date-regexp t)
+ (delete-region (progn (beginning-of-line) (point))
+ (progn (end-of-line) (point)))
(beginning-of-line))
- (goto-char (point-max)))
+ (goto-char (point-max))
+ (setq newline t))
(insert (article-make-date-line date type))
;; Do highlighting.
- (forward-line -1)
+ (beginning-of-line)
(when (looking-at "\\([^:]+\\): *\\(.*\\)$")
- (put-text-property (match-beginning 1) (match-end 1)
+ (put-text-property (match-beginning 1) (1+ (match-end 1))
'face bface)
(put-text-property (match-beginning 2) (match-end 2)
- 'face eface))))))))
+ 'face eface))
+ (when newline
+ (end-of-line)
+ (insert "\n"))))))))
(defun article-make-date-line (date type)
"Return a DATE line of TYPE."
((eq type 'local)
(concat "Date: " (condition-case ()
(timezone-make-date-arpa-standard date)
- (error date))
- "\n"))
+ (error date))))
;; Convert to Universal Time.
((eq type 'ut)
(concat "Date: "
(condition-case ()
(timezone-make-date-arpa-standard date nil "UT")
- (error date))
- "\n"))
+ (error date))))
;; Get the original date from the article.
((eq type 'original)
- (concat "Date: " date "\n"))
+ (concat "Date: " date))
;; Let the user define the format.
((eq type 'user)
(concat
(ignore-errors
(gnus-encode-date
(timezone-make-date-arpa-standard
- date nil "UT"))))
- "\n"))
+ date nil "UT"))))))
;; Do an X-Sent lapsed format.
((eq type 'lapsed)
;; If the date is seriously mangled, the timezone functions are
num prev)
(cond
((null real-time)
- "X-Sent: Unknown\n")
+ "X-Sent: Unknown")
((zerop sec)
- "X-Sent: Now\n")
+ "X-Sent: Now")
(t
(concat
"X-Sent: "
;; If dates are odd, then it might appear like the
;; article was sent in the future.
(if (> real-sec 0)
- " ago\n"
- " in the future\n"))))))
+ " ago"
+ " in the future"))))))
(t
(error "Unknown conversion type: %s" type))))
(interactive (list t))
(article-date-ut 'lapsed highlight))
+(defun article-update-date-lapsed ()
+ "Function to be run from a timer to update the lapsed time line."
+ (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))))))
+
+(defun gnus-start-date-timer (&optional n)
+ "Start a timer to update the X-Sent header in the article buffers.
+The numerical prefix says how frequently (in seconds) the function
+is to run."
+ (interactive "p")
+ (unless n
+ (setq n 1))
+ (gnus-stop-date-timer)
+ (setq article-lapsed-timer
+ (nnheader-run-at-time 1 n 'article-update-date-lapsed)))
+
+(defun gnus-stop-date-timer ()
+ "Stop the X-Sent timer."
+ (interactive)
+ (when article-lapsed-timer
+ (nnheader-cancel-timer article-lapsed-timer)
+ (setq article-lapsed-timer nil)))
+
(defun article-date-user (&optional highlight)
"Convert the current article date to the user-defined format.
This format is defined by the `gnus-article-time-format' variable."
(let ((gnus-visible-headers
(or gnus-saved-headers gnus-visible-headers))
(gnus-article-buffer save-buffer))
- (gnus-article-hide-headers 1 t)))
+ (save-excursion
+ (set-buffer save-buffer)
+ (article-hide-headers 1 t))))
(save-window-excursion
(if (not gnus-default-article-saver)
- (error "No default saver is defined.")
+ (error "No default saver is defined")
;; !!! Magic! The saving functions all save
;; `gnus-original-article-buffer' (or so they think), but we
;; bind that variable to our save-buffer.
Optional argument FILENAME specifies file name.
Directory to save to is default to `gnus-article-save-directory'."
(interactive)
- (gnus-set-global-variables)
(setq filename (gnus-read-save-file-name
"Save %s in rmail file:" filename
gnus-rmail-save-name gnus-newsgroup-name
(save-excursion
(save-restriction
(widen)
- (gnus-output-to-rmail filename)))))
+ (gnus-output-to-rmail filename))))
+ filename)
(defun gnus-summary-save-in-mail (&optional filename)
"Append this article to Unix mail file.
Optional argument FILENAME specifies file name.
Directory to save to is default to `gnus-article-save-directory'."
(interactive)
- (gnus-set-global-variables)
(setq filename (gnus-read-save-file-name
"Save %s in Unix mail file:" filename
gnus-mail-save-name gnus-newsgroup-name
(if (and (file-readable-p filename)
(mail-file-babyl-p filename))
(gnus-output-to-rmail filename t)
- (gnus-output-to-mail filename))))))
+ (gnus-output-to-mail filename)))))
+ filename)
(defun gnus-summary-save-in-file (&optional filename overwrite)
"Append this article to file.
Optional argument FILENAME specifies file name.
Directory to save to is default to `gnus-article-save-directory'."
(interactive)
- (gnus-set-global-variables)
(setq filename (gnus-read-save-file-name
"Save %s in file:" filename
gnus-file-save-name gnus-newsgroup-name
(when (and overwrite
(file-exists-p filename))
(delete-file filename))
- (gnus-output-to-file filename)))))
+ (gnus-output-to-file filename))))
+ filename)
(defun gnus-summary-write-to-file (&optional filename)
"Write this article to a file.
Optional argument FILENAME specifies file name.
The directory to save in defaults to `gnus-article-save-directory'."
(interactive)
- (gnus-set-global-variables)
(setq filename (gnus-read-save-file-name
"Save %s body in file:" filename
gnus-file-save-name gnus-newsgroup-name
(goto-char (point-min))
(when (search-forward "\n\n" nil t)
(narrow-to-region (point) (point-max)))
- (gnus-output-to-file filename)))))
+ (gnus-output-to-file filename))))
+ filename)
(defun gnus-summary-save-in-pipe (&optional command)
"Pipe this article to subprocess."
(interactive)
- (gnus-set-global-variables)
(setq command
(cond ((eq command 'default)
gnus-last-shell-command)
article-date-user
article-date-lapsed
article-emphasize
+ article-treat-dumbquotes
(article-show-all . gnus-article-show-all-headers))))
\f
;;;
(progn
(save-excursion
(set-buffer summary-buffer)
+ (push article gnus-newsgroup-history)
(setq gnus-last-article gnus-current-article
- gnus-newsgroup-history (cons gnus-current-article
- gnus-newsgroup-history)
gnus-current-article 0
gnus-current-headers nil
gnus-article-current nil)
;; `gnus-current-article' must be an article number.
(save-excursion
(set-buffer summary-buffer)
+ (push article gnus-newsgroup-history)
(setq gnus-last-article gnus-current-article
- gnus-newsgroup-history (cons gnus-current-article
- gnus-newsgroup-history)
gnus-current-article article
gnus-current-headers
(gnus-summary-article-header gnus-current-article)
(cons gnus-newsgroup-name gnus-current-article))
(unless (vectorp gnus-current-headers)
(setq gnus-current-headers nil))
+ (gnus-summary-goto-subject gnus-current-article)
(gnus-summary-show-thread)
(run-hooks 'gnus-mark-article-hook)
(gnus-set-mode-line 'summary)
(interactive)
(if (not (gnus-buffer-live-p gnus-summary-buffer))
(error "There is no summary buffer for this article buffer")
+ (gnus-article-set-globals)
(gnus-configure-windows 'article)
(gnus-summary-goto-subject gnus-current-article)))
(interactive "P")
(when (and (not force)
(gnus-group-read-only-p))
- (error "The current newsgroup does not support article editing."))
+ (error "The current newsgroup does not support article editing"))
(gnus-article-edit-article
- `(lambda ()
+ `(lambda (no-highlight)
(gnus-summary-edit-article-done
,(or (mail-header-references gnus-current-headers) "")
- ,(gnus-group-read-only-p) ,gnus-summary-buffer))))
+ ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight))))
(defun gnus-article-edit-article (exit-func)
"Start editing the contents of the current article buffer."
(setq gnus-prev-winconf winconf)
(gnus-message 6 "C-c C-c to end edits")))
-(defun gnus-article-edit-done ()
+(defun gnus-article-edit-done (&optional arg)
"Update the article edits and exit."
- (interactive)
+ (interactive "P")
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (when (search-forward "\n\n" nil 1)
+ (let ((lines (count-lines (point) (point-max)))
+ (length (- (point-max) (point)))
+ (case-fold-search t)
+ (body (copy-marker (point))))
+ (goto-char (point-min))
+ (when (re-search-forward "^content-length:[ \t]\\([0-9]+\\)" body t)
+ (delete-region (match-beginning 1) (match-end 1))
+ (insert (number-to-string length)))
+ (goto-char (point-min))
+ (when (re-search-forward
+ "^x-content-length:[ \t]\\([0-9]+\\)" body t)
+ (delete-region (match-beginning 1) (match-end 1))
+ (insert (number-to-string length)))
+ (goto-char (point-min))
+ (when (re-search-forward "^lines:[ \t]\\([0-9]+\\)" body t)
+ (delete-region (match-beginning 1) (match-end 1))
+ (insert (number-to-string lines)))))))
(let ((func gnus-article-edit-done-function)
(buf (current-buffer))
(start (window-start)))
(save-excursion
(set-buffer buf)
(let ((buffer-read-only nil))
- (funcall func)))
+ (funcall func arg)))
(set-buffer buf)
(set-window-start (get-buffer-window buf) start)
(set-window-point (get-buffer-window buf) (point))))
("\\bnews:\\([^>\n\t ]*@[^>\n\t ]*\\)" 0 t gnus-button-message-id 1)
("\\(\\b<\\(url: ?\\)?news:\\(//\\)?\\([^>\n\t ]*\\)>\\)" 1 t
gnus-button-fetch-group 4)
- ("\\bnews:\\(//\\)?\\([^>\n\t ]+\\)" 0 t gnus-button-fetch-group 2)
+ ("\\bnews:\\(//\\)?\\([^'\">\n\t ]+\\)" 0 t gnus-button-fetch-group 2)
("\\bin\\( +article\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2
t gnus-button-message-id 3)
- ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>" 0 t gnus-url-mailto 1)
- ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 2)
+ ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>" 0 t gnus-url-mailto 2)
+ ("\\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)
;; Raw URLs.
;;; Internal functions:
+(defun gnus-article-set-globals ()
+ (save-excursion
+ (set-buffer gnus-summary-buffer)
+ (gnus-set-global-variables)))
+
(defun gnus-signature-toggle (end)
(save-excursion
(set-buffer gnus-article-buffer)
projects / gnus / blobdiff