X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-art.el;h=b0a2c23e750cb58dd00837bb4c97cd185bf6af96;hb=b18b139721468723906cc870944cee918d16de1a;hp=74f728c0f6105fab7137b28e41a1573c98a0d0c0;hpb=1a67da7381c23de4679cfef00a2ad1dbdd076aa1;p=gnus diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 74f728c0f..b0a2c23e7 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -25,6 +25,8 @@ ;;; Code: +(eval-when-compile (require 'cl)) + (require 'custom) (require 'gnus) (require 'gnus-sum) @@ -93,7 +95,7 @@ "^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 @@ -102,7 +104,7 @@ If `gnus-visible-headers' is non-nil, this variable will be ignored." :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." @@ -127,12 +129,14 @@ this list." (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 '("^-- $" "^-- *$") @@ -169,7 +173,7 @@ asynchronously. The compressed face will be piped to this command." (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 @@ -240,7 +244,7 @@ Esample: (_/*word*/_)." (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) @@ -274,7 +278,7 @@ If `gnus-save-all-headers' is non-nil, this variable will be ignored. 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. @@ -522,6 +526,8 @@ displayed by the first non-nil matching CONTENT face." ;;; 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) @@ -583,7 +589,8 @@ Initialized from `text-mode-syntax-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." @@ -591,7 +598,8 @@ Initialized from `text-mode-syntax-table.") (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." @@ -613,6 +621,7 @@ Initialized from `text-mode-syntax-table.") 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) @@ -738,7 +747,25 @@ always hide." (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 @@ -753,7 +780,29 @@ always hide." (point-max))) 'boring-headers)))) -;; Written by Per Abrahamsen . +(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) @@ -831,7 +880,7 @@ always hide." (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) @@ -959,28 +1008,28 @@ always hide." ;; 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. @@ -1124,7 +1173,9 @@ Put point at the beginning of the signature separator." 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." @@ -1132,6 +1183,7 @@ Put point at the beginning of the signature separator." (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) @@ -1142,8 +1194,8 @@ Put point at the beginning of the signature separator." (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)) @@ -1230,7 +1282,7 @@ how much time has lapsed since DATE." 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 @@ -1242,17 +1294,22 @@ how much time has lapsed since DATE." (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." @@ -1264,18 +1321,16 @@ how much time has lapsed since DATE." ((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 @@ -1284,8 +1339,7 @@ how much time has lapsed since DATE." (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 @@ -1308,9 +1362,9 @@ how much time has lapsed since DATE." 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: " @@ -1336,8 +1390,8 @@ how much time has lapsed since DATE." ;; 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)))) @@ -1358,6 +1412,34 @@ function and want to see what the date was before converting." (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." @@ -1412,10 +1494,12 @@ 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. @@ -1527,7 +1611,6 @@ This format is defined by the `gnus-article-time-format' variable." 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 @@ -1536,14 +1619,14 @@ Directory to save to is default to `gnus-article-save-directory'." (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 @@ -1555,14 +1638,14 @@ Directory to save to is default to `gnus-article-save-directory'." (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 @@ -1574,7 +1657,8 @@ Directory to save to is default to `gnus-article-save-directory'." (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. @@ -1588,7 +1672,6 @@ The directory to save in defaults to `gnus-article-save-directory'." 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 @@ -1600,12 +1683,12 @@ The directory to save in defaults to `gnus-article-save-directory'." (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) @@ -1735,6 +1818,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is article-date-user article-date-lapsed article-emphasize + article-treat-dumbquotes (article-show-all . gnus-article-show-all-headers)))) ;;; @@ -1941,9 +2025,8 @@ If ALL-HEADERS is non-nil, no headers are hidden." (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) @@ -1961,9 +2044,8 @@ If ALL-HEADERS is non-nil, no headers are hidden." ;; `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) @@ -1971,6 +2053,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (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) @@ -2176,6 +2259,7 @@ Argument LINES specifies lines to be scrolled down." (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))) @@ -2467,12 +2551,12 @@ groups." (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." @@ -2485,9 +2569,31 @@ groups." (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))) @@ -2495,7 +2601,7 @@ groups." (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)))) @@ -2560,11 +2666,11 @@ groups." ("\\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) - ("\\( \n\t]+\\)>" 0 t gnus-url-mailto 1) - ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 2) + ("\\( \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... ("]*\\)>" 0 t gnus-button-embedded-url 1) ;; Raw URLs. @@ -2872,6 +2978,11 @@ specified by `gnus-button-alist'." ;;; 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)