X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-art.el;h=f0f3e3ece6e146ac8d563e81057c0fd7e931deda;hb=635f54ad1a1824db5dcc8acc443fe8005501045e;hp=44bf80df5136ee4ed46beb15377891cb02afd554;hpb=77c2b3c6707324bdf2d5376e1c97cdfff7014c74;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 44bf80d..f0f3e3e 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -1,8 +1,9 @@ -;;; gnus-art.el --- article mode commands for Gnus +;;; gnus-art.el --- article mode commands for Semi-gnus ;; Copyright (C) 1996,97 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen -;; Keywords: news +;; MORIOKA Tomohiko +;; Keywords: mail, news, MIME ;; This file is part of GNU Emacs. @@ -33,6 +34,8 @@ (require 'gnus-spec) (require 'gnus-int) (require 'browse-url) +(require 'alist) +(require 'mime-view) (defgroup gnus-article nil "Article display." @@ -104,7 +107,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." @@ -155,7 +158,10 @@ longer (in lines) than that number. If it is a function, the function will be called without any parameters, and if it returns nil, there is no signature in the buffer. If it is a string, it will be used as a regexp. If it matches, the text in question is not a signature." - :type '(choice integer number function regexp) + :type '(choice (integer :value 200) + (number :value 4.0) + (function :value fun) + (regexp :value ".*")) :group 'gnus-article-signature) (defcustom gnus-hidden-properties '(invisible t intangible t) @@ -270,7 +276,7 @@ each invocation of the saving commands." :group 'gnus-article-saving :type '(choice (item always) (item :tag "never" nil) - (sexp :tag "once" :format "%t"))) + (sexp :tag "once" :format "%t\n" :value t))) (defcustom gnus-saved-headers gnus-visible-headers "Headers to keep if `gnus-save-all-headers' is nil. @@ -349,22 +355,22 @@ If this form or function returns a string, this string will be used as a possible file name; and if it returns a non-nil list, that list will be used as possible file names." :group 'gnus-article-saving - :type '(repeat (choice (list function) - (cons regexp (repeat string)) - sexp))) + :type '(repeat (choice (list :value (fun) function) + (cons :value ("" "") regexp (repeat string)) + (sexp :value nil)))) (defcustom gnus-strict-mime t "*If nil, MIME-decode even if there is no Mime-Version header." :group 'gnus-article-mime :type 'boolean) -(defcustom gnus-show-mime-method 'metamail-buffer +(defcustom gnus-show-mime-method 'gnus-article-preview-mime-message "Function to process a MIME message. The function is called from the article buffer." :group 'gnus-article-mime :type 'function) -(defcustom gnus-decode-encoded-word-method 'gnus-article-de-quoted-unreadable +(defcustom gnus-decode-encoded-word-method 'gnus-article-decode-encoded-word "*Function to decode MIME encoded words. The function is called from the article buffer." :group 'gnus-article-mime @@ -915,84 +921,11 @@ characters to translate to." (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)))) - -(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) - (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)))))) - -(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. -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) - (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)))))) - -(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"))))) +(defun gnus-article-decode-rfc1522 () + "Decode MIME encoded-words in header fields." + (let (buffer-read-only) + (eword-decode-header) + )) (defun article-hide-pgp (&optional arg) "Toggle hiding of any PGP headers and signatures in the current article. @@ -1119,6 +1052,17 @@ always hide." (article-remove-trailing-blank-lines) (article-strip-multiple-blank-lines)) +(defun article-strip-all-blank-lines () + "Strip all blank lines." + (interactive) + (save-excursion + (let ((inhibit-point-motion-hooks t) + buffer-read-only) + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (while (re-search-forward "^[ \t]*\n" nil t) + (replace-match "" t t))))) + (defvar mime::preview/content-list) (defvar mime::preview-content-info/point-min) (defun gnus-article-narrow-to-signature () @@ -1282,7 +1226,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 @@ -1297,7 +1241,8 @@ how much time has lapsed since DATE." (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. (beginning-of-line) @@ -1305,7 +1250,10 @@ how much time has lapsed since DATE." (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." @@ -1358,9 +1306,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: " @@ -1411,24 +1359,29 @@ function and want to see what the date was before converting." (defun article-update-date-lapsed () "Function to be run from a timer to update the lapsed time line." (save-excursion - (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))))) + (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 () - "Start a timer to update the X-Sent header in the article buffers." - (interactive) +(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 1 'article-update-date-lapsed))) + (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-delete-timer article-lapsed-timer) + (nnheader-cancel-timer article-lapsed-timer) (setq article-lapsed-timer nil))) (defun article-date-user (&optional highlight) @@ -1610,7 +1563,8 @@ 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. @@ -1628,7 +1582,8 @@ 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. @@ -1646,7 +1601,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. @@ -1671,7 +1627,8 @@ 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." @@ -1799,6 +1756,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is article-strip-multiple-blank-lines article-strip-leading-space article-strip-blank-lines + article-strip-all-blank-lines article-date-local article-date-original article-date-ut @@ -1966,6 +1924,52 @@ commands: (forward-line line) (point))))) +;;; @@ article filters +;;; +(defun gnus-article-preview-mime-message () + (make-local-variable 'mime-button-mother-dispatcher) + (setq mime-button-mother-dispatcher + (function gnus-article-push-button)) + (let ((default-mime-charset + (save-excursion + (set-buffer gnus-summary-buffer) + default-mime-charset)) + ) + (save-excursion + (mime-view-mode nil nil nil gnus-original-article-buffer + gnus-article-buffer + gnus-article-mode-map) + )) + (run-hooks 'gnus-mime-article-prepare-hook) + ) + +(defun gnus-article-decode-encoded-word () + "Header filter for gnus-article-mode. +It is registered to variable `mime-view-content-header-filter-alist'." + (goto-char (point-min)) + (let ((charset (save-excursion + (set-buffer gnus-summary-buffer) + default-mime-charset))) + (save-restriction + (std11-narrow-to-header) + (goto-char (point-min)) + (while (re-search-forward "^[^ \t:]+:" nil t) + (let ((start (match-beginning 0)) + (end (std11-field-end)) + ) + (save-restriction + (narrow-to-region start end) + (decode-mime-charset-region start end charset) + (goto-char (point-max)) + ))) + (eword-decode-header) + ) + (decode-mime-charset-region (point) (point-max) charset) + (mime-maybe-hide-echo-buffer) + ) + (run-hooks 'gnus-mime-article-prepare-hook) + ) + (defun gnus-article-prepare (article &optional all-headers header) "Prepare ARTICLE in article mode buffer. ARTICLE should either be an article number or a Message-ID. @@ -2435,6 +2439,8 @@ If given a prefix, show the hidden text instead." ;; Check asynchronous pre-fetch. ((gnus-async-request-fetched-article group article (current-buffer)) (gnus-async-prefetch-next group article gnus-summary-buffer) + (when (and (numberp article) gnus-keep-backlog) + (gnus-backlog-enter-article group article (current-buffer))) 'article) ;; Check the cache. ((and gnus-use-cache @@ -2559,6 +2565,28 @@ groups." (defun gnus-article-edit-done (&optional arg) "Update the article edits and exit." (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))) @@ -2632,7 +2660,7 @@ groups." ("\\(\\b<\\(url: ?\\)?news:\\(//\\)?\\([^>\n\t ]*\\)>\\)" 1 t gnus-button-fetch-group 4) ("\\bnews:\\(//\\)?\\([^'\">\n\t ]+\\)" 0 t gnus-button-fetch-group 2) - ("\\bin\\( +article\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2 + ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2 t gnus-button-message-id 3) ("\\( \n\t]+\\)>" 0 t gnus-url-mailto 2) ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1) @@ -3177,6 +3205,56 @@ forbidden in URL encoding." (gnus-article-prev-page) (select-window win))) + +;;; @ for mime-view +;;; + +(defun gnus-content-header-filter () + "Header filter for mime-view. +It is registered to variable `mime-view-content-header-filter-alist'." + (goto-char (point-min)) + (while (re-search-forward "^[^ \t:]+:" nil t) + (let ((start (match-beginning 0)) + (end (std11-field-end)) + ) + (save-restriction + (narrow-to-region start end) + (decode-mime-charset-region start end default-mime-charset) + (goto-char (point-max)) + ))) + (eword-decode-header) + ) + +(defun mime-view-quitting-method-for-gnus () + (if (not gnus-show-mime) + (mime-view-kill-buffer)) + (delete-other-windows) + (gnus-article-show-summary) + (if (or (not gnus-show-mime) + (null gnus-have-all-headers)) + (gnus-summary-select-article nil t) + )) + +(set-alist 'mime-view-content-header-filter-alist + 'gnus-original-article-mode + (function gnus-content-header-filter)) + +(set-alist 'mime-text-decoder-alist + 'gnus-original-article-mode + (function mime-text-decode-buffer)) + +(set-alist 'mime-view-quitting-method-alist + 'gnus-original-article-mode + (function mime-view-quitting-method-for-gnus)) + +(set-alist 'mime-view-show-summary-method + 'gnus-original-article-mode + (function mime-view-quitting-method-for-gnus)) + + +;;; @ end +;;; + (gnus-ems-redefine) (provide 'gnus-art)