;;; gnus-art.el --- article mode commands for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001
+;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
(require 'gnus-sum)
(require 'gnus-spec)
(require 'gnus-int)
+(require 'gnus-win)
(require 'mm-bodies)
(require 'mail-parse)
(require 'mm-decode)
(require 'wid-edit)
(require 'mm-uu)
+(autoload 'gnus-msg-mail "gnus-msg" nil t)
+(autoload 'gnus-button-mailto "gnus-msg")
+(autoload 'gnus-button-reply "gnus-msg" nil t)
+
(defgroup gnus-article nil
"Article display."
:link '(custom-manual "(gnus)The Article Buffer")
"^List-[A-Za-z]+:" "^X-Listprocessor-Version:"
"^X-Received:" "^X-Distribute:" "^X-Sequence:" "^X-Juno-Line-Breaks:"
"^X-Notes-Item:" "^X-MS-TNEF-Correlator:" "^x-uunet-gateway:"
- "^X-Received:" "^Content-length:" "X-precedence:")
+ "^X-Received:" "^Content-length:" "X-precedence:"
+ "^X-Authenticated-User:" "^X-Comment" "^X-Report:" "^X-Abuse-Info:"
+ "^X-HTTP-Proxy:" "^X-Mydeja-Info:" "^X-Copyright" "^X-No-Markup:"
+ "^X-Abuse-Info:" "^X-From_:" "^X-Accept-Language:" "^Errors-To:"
+ "^X-BeenThere:" "^X-Mailman-Version:" "^List-Help:" "^List-Post:"
+ "^List-Subscribe:" "^List-Id:" "^List-Unsubscribe:" "^List-Archive:"
+ "^X-Content-length:" "^X-Posting-Agent:" "^Original-Received:"
+ "^X-Request-PGP:" "^X-Fingerprint:" "^X-WRIEnvto:" "^X-WRIEnvfrom:"
+ "^X-Virus-Scanned:" "^X-Delivery-Agent:" "^Posted-Date:" "^X-Gateway:"
+ "^X-Local-Origin:" "^X-Local-Destination:")
"*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."
(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', `date', `long-to', and `many-to'."
+Possible values in this list are:
+
+ 'empty Headers with no content.
+ 'newsgroups Newsgroup identical to Gnus group.
+ 'to-address To identical to To-address.
+ 'followup-to Followup-to identical to Newsgroups.
+ 'reply-to Reply-to identical to From.
+ 'date Date less than four days old.
+ 'long-to To and/or Cc longer than 1024 characters.
+ 'many-to Multiple To and/or Cc."
: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 "Newsgroups identical to Gnus group." newsgroups)
+ (const :tag "To identical to To-address." to-address)
+ (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 "Very long To and/or Cc header." long-to)
+ (const :tag "To and/or Cc longer than 1024 characters." long-to)
(const :tag "Multiple To and/or Cc headers." many-to))
:group 'gnus-article-hiding)
;; Fixme: This isn't the right thing for mixed graphical and and
;; non-graphical frames in a session.
-;; gnus-xmas.el overrides this for XEmacs.
(defcustom gnus-article-x-face-command
- (if (and (fboundp 'image-type-available-p)
- (image-type-available-p 'xbm))
- 'gnus-article-display-xface
- (if gnus-article-compface-xbm
- "{ echo '/* Width=48, Height=48 */'; uncompface; } | display -"
- "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | \
-display -"))
+ (if (featurep 'xemacs)
+ (if (or (gnus-image-type-available-p 'xface)
+ (gnus-image-type-available-p 'xpm))
+ 'gnus-xmas-article-display-xface
+ "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | ee -")
+ (if (gnus-image-type-available-p 'xbm)
+ 'gnus-article-display-xface
+ (if gnus-article-compface-xbm
+ "{ echo '/* Width=48, Height=48 */'; uncompface; } | display -"
+ "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | \
+display -")))
"*String or function to be executed to display an X-Face header.
If it is a string, the command will be executed in a sub-shell
asynchronously. The compressed face will be piped to this command."
- :type '(choice string
- (function-item gnus-article-display-xface)
+ :type `(choice string
+ (function-item
+ ,(if (featurep 'xemacs)
+ 'gnus-xmas-article-display-xface
+ 'gnus-article-display-xface))
function)
+ :version "21.1"
:group 'gnus-article-washing)
(defcustom gnus-article-x-face-too-ugly nil
(defcustom gnus-article-banner-alist nil
"Banner alist for stripping.
-For example,
- ((egroups . \"^[ \\t\\n]*-------------------+\\\\( eGroups Sponsor -+\\\\)?....\\n\\\\(.+\\n\\\\)+\"))"
+For example,
+ ((egroups . \"^[ \\t\\n]*-------------------+\\\\( \\\\(e\\\\|Yahoo! \\\\)Groups Sponsor -+\\\\)?....\\n\\\\(.+\\n\\\\)+\"))"
:version "21.1"
:type '(repeat (cons symbol regexp))
:group 'gnus-article-washing)
-(defcustom gnus-article-banner-alist nil
- "Banner alist for stripping.
-For example,
- ((egroups . \"^[ \\t\\n]*-------------------+\\\\( eGroups Sponsor -+\\\\)?....\\n\\\\(.+\\n\\\\)+\"))"
- :version "21.1"
- :type '(repeat (cons symbol regexp))
- :group 'gnus-article-washing)
+(gnus-define-group-parameter
+ banner
+ :variable-document
+ "Alist of regexps (to match group names) and banner."
+ :variable-group gnus-article-washing
+ :parameter-type
+ '(choice :tag "Banner"
+ :value nil
+ (const :tag "Remove signature" signature)
+ (symbol :tag "Item in `gnus-article-banner-alist'" none)
+ regexp
+ (const :tag "None" nil))
+ :parameter-document
+ "If non-nil, specify how to remove `banners' from articles.
+
+Symbol `signature' means to remove signatures delimited by
+`gnus-signature-separator'. Any other symbol is used to look up a
+regular expression to match the banner in `gnus-article-banner-alist'.
+A string is used as a regular expression to match the banner
+directly.")
(defcustom gnus-emphasis-alist
(let ((format
"Face used for displaying highlighted words."
:group 'gnus-article-emphasis)
+(defface gnus-body-boundary-face
+ '((((class color)
+ (background dark))
+ (:background "white")
+ (:foreground "black"))
+ (((class color)
+ (background light))
+ (:background "black")
+ (:foreground "white"))
+ (t
+ ()))
+ "Face for the body separator.")
+
(defcustom gnus-article-time-format "%a, %b %d %Y %T %Z"
"Format for display of Date headers in article bodies.
See `format-time-string' for the possible values.
* gnus-summary-save-in-mail (Unix mail format)
* gnus-summary-save-in-folder (MH folder)
* gnus-summary-save-in-file (article format)
+* gnus-summary-save-body-in-file (article body)
* gnus-summary-save-in-vm (use VM's folder format)
* gnus-summary-write-to-file (article format -- overwrite)."
:group 'gnus-article-saving
(function-item gnus-summary-save-in-mail)
(function-item gnus-summary-save-in-folder)
(function-item gnus-summary-save-in-file)
+ (function-item gnus-summary-save-body-in-file)
(function-item gnus-summary-save-in-vm)
(function-item gnus-summary-write-to-file)))
:type 'hook
:group 'gnus-article-various)
+(when (featurep 'xemacs)
+ ;; Extracted from gnus-xmas-define in order to preserve user settings
+ (when (fboundp 'turn-off-scroll-in-place)
+ (add-hook 'gnus-article-mode-hook 'turn-off-scroll-in-place))
+ ;; Extracted from gnus-xmas-redefine in order to preserve user settings
+ (add-hook 'gnus-article-mode-hook 'gnus-xmas-article-menu-add))
+
(defcustom gnus-article-menu-hook nil
"*Hook run after the creation of the article mode menu."
:type 'hook
(face :value default)))))
(defcustom gnus-article-decode-hook
- '(article-decode-charset article-decode-encoded-words)
+ '(article-decode-charset article-decode-encoded-words
+ article-decode-group-name)
"*Hook run to decode charsets in articles."
:group 'gnus-article-headers
:type 'hook)
:type '(repeat regexp))
(defcustom gnus-unbuttonized-mime-types '(".*/.*")
- "List of MIME types that should not be given buttons when rendered inline."
+ "List of MIME types that should not be given buttons when rendered inline.
+See also `gnus-buttonized-mime-types' which may override this variable."
+ :version "21.1"
+ :group 'gnus-article-mime
+ :type '(repeat regexp))
+
+(defcustom gnus-buttonized-mime-types nil
+ "List of MIME types that should be given buttons when rendered inline.
+If set, this variable overrides `gnus-unbuttonized-mime-types'.
+To see e.g. security buttons you could set this to
+`(\"multipart/signed\")'."
:version "21.1"
:group 'gnus-article-mime
:type '(repeat regexp))
(defcustom gnus-article-mime-match-handle-function 'undisplayed-alternative
"Function called with a MIME handle as the argument.
This is meant for people who want to view first matched part.
-For `undisplayed-alternative' (default), the first undisplayed
-part or alternative part is used. For `undisplayed', the first
-undisplayed part is used. For a function, the first part which
+For `undisplayed-alternative' (default), the first undisplayed
+part or alternative part is used. For `undisplayed', the first
+undisplayed part is used. For a function, the first part which
the function return `t' is used. For `nil', the first part is
used."
:version "21.1"
:group 'gnus-article-mime
- :type '(choice
+ :type '(choice
(item :tag "first" :value nil)
(item :tag "undisplayed" :value undisplayed)
- (item :tag "undisplayed or alternative"
+ (item :tag "undisplayed or alternative"
:value undisplayed-alternative)
(function)))
(defcustom gnus-treat-highlight-signature '(or last (typep "text/x-vcard"))
"Highlight the signature.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles'."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(put 'gnus-treat-highlight-signature 'highlight t)
:type gnus-article-treat-head-custom)
(put 'gnus-treat-buttonize-head 'highlight t)
-(defcustom gnus-treat-emphasize
+(defcustom gnus-treat-emphasize
(and (or window-system
(featurep 'xemacs)
(>= (string-to-number emacs-version) 21))
:group 'gnus-article-treat
:type gnus-article-treat-custom)
+(defcustom gnus-treat-leading-whitespace nil
+ "Remove leading whitespace in headers.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
+ :group 'gnus-article-treat
+ :type gnus-article-treat-custom)
+
(defcustom gnus-treat-hide-headers 'head
"Hide headers.
Valid values are nil, t, `head', `last', an integer or a predicate.
:group 'gnus-article-treat
:type gnus-article-treat-custom)
-(defcustom gnus-treat-hide-citation-maybe nil
- "Hide cited text.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
- :group 'gnus-article-treat
- :type gnus-article-treat-custom)
-
(defcustom gnus-treat-strip-list-identifiers 'head
"Strip list identifiers from `gnus-list-identifiers`.
Valid values are nil, t, `head', `last', an integer or a predicate.
:group 'gnus-article-treat
:type gnus-article-treat-head-custom)
+(defcustom gnus-treat-date-english nil
+ "Display the Date in a format that can be read aloud in English.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
+ :group 'gnus-article-treat
+ :type gnus-article-treat-head-custom)
+
(defcustom gnus-treat-date-lapsed nil
"Display the Date header in a way that says how much time has elapsed.
Valid values are nil, t, `head', `last', an integer or a predicate.
:group 'gnus-article-treat
:type gnus-article-treat-custom)
+(defcustom gnus-treat-unfold-headers 'head
+ "Unfold folded header lines.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
+ :group 'gnus-article-treat
+ :type gnus-article-treat-custom)
+
(defcustom gnus-treat-overstrike t
"Treat overstrike highlighting.
Valid values are nil, t, `head', `last', an integer or a predicate.
:type gnus-article-treat-custom)
(put 'gnus-treat-overstrike 'highlight t)
-(defcustom gnus-treat-display-xface
+(defcustom gnus-treat-display-xface
(and (or (and (fboundp 'image-type-available-p)
(image-type-available-p 'xbm)
(string-match "^0x" (shell-command-to-string "uncompface")))
Valid values are nil, t, `head', `last', an integer or a predicate.
See the manual for details."
:group 'gnus-article-treat
+ :version "21.1"
:type gnus-article-treat-head-custom)
(put 'gnus-treat-display-xface 'highlight t)
-(defcustom gnus-treat-display-smileys
+(defcustom gnus-treat-display-smileys
(if (or (and (featurep 'xemacs)
(featurep 'xpm))
(and (fboundp 'image-type-available-p)
Valid values are nil, t, `head', `last', an integer or a predicate.
See the manual for details."
:group 'gnus-article-treat
+ :version "21.1"
:type gnus-article-treat-custom)
(put 'gnus-treat-display-smileys 'highlight t)
-(defcustom gnus-treat-display-picons (if (featurep 'xemacs) 'head nil)
- "Display picons.
+(defcustom gnus-treat-from-picon
+ (if (gnus-image-type-available-p 'xpm)
+ 'head nil)
+ "Display picons in the From header.
Valid values are nil, t, `head', `last', an integer or a predicate.
See the manual for details."
:group 'gnus-article-treat
:type gnus-article-treat-head-custom)
-(put 'gnus-treat-display-picons 'highlight t)
+(put 'gnus-treat-from-picon 'highlight t)
+
+(defcustom gnus-treat-mail-picon
+ (if (gnus-image-type-available-p 'xpm)
+ 'head nil)
+ "Display picons in To and Cc headers.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
+ :group 'gnus-article-treat
+ :type gnus-article-treat-head-custom)
+(put 'gnus-treat-mail-picon 'highlight t)
+
+(defcustom gnus-treat-newsgroups-picon
+ (if (gnus-image-type-available-p 'xpm)
+ 'head nil)
+ "Display picons in the Newsgroups and Followup-To headers.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
+ :group 'gnus-article-treat
+ :type gnus-article-treat-head-custom)
+(put 'gnus-treat-newsgroups-picon 'highlight t)
+
+(defcustom gnus-treat-body-boundary
+ (if (or gnus-treat-newsgroups-picon
+ gnus-treat-mail-picon
+ gnus-treat-from-picon)
+ 'head nil)
+ "Draw a boundary at the end of the headers.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
+ :version "21.1"
+ :group 'gnus-article-treat
+ :type gnus-article-treat-custom)
(defcustom gnus-treat-capitalize-sentences nil
"Capitalize sentence-starting words.
;;; Internal variables
+(defvar gnus-english-month-names
+ '("January" "February" "March" "April" "May" "June" "July" "August"
+ "September" "October" "November" "December"))
+
(defvar article-goto-body-goes-to-point-min-p nil)
(defvar gnus-article-wash-types nil)
(defvar gnus-article-emphasis-alist nil)
(gnus-treat-fill-article gnus-article-fill-cited-article)
(gnus-treat-fill-long-lines gnus-article-fill-long-lines)
(gnus-treat-strip-cr gnus-article-remove-cr)
- (gnus-treat-emphasize gnus-article-emphasize)
(gnus-treat-display-xface gnus-article-display-x-face)
+ (gnus-treat-date-ut gnus-article-date-ut)
+ (gnus-treat-date-local gnus-article-date-local)
+ (gnus-treat-date-english gnus-article-date-english)
+ (gnus-treat-date-lapsed gnus-article-date-lapsed)
+ (gnus-treat-date-original gnus-article-date-original)
+ (gnus-treat-date-user-defined gnus-article-date-user)
+ (gnus-treat-date-iso8601 gnus-article-date-iso8601)
(gnus-treat-hide-headers gnus-article-maybe-hide-headers)
(gnus-treat-hide-boring-headers gnus-article-hide-boring-headers)
(gnus-treat-hide-signature gnus-article-hide-signature)
(gnus-treat-hide-citation gnus-article-hide-citation)
(gnus-treat-hide-citation-maybe gnus-article-hide-citation-maybe)
(gnus-treat-strip-list-identifiers gnus-article-hide-list-identifiers)
+ (gnus-treat-leading-whitespace gnus-article-remove-leading-whitespace)
(gnus-treat-strip-pgp gnus-article-hide-pgp)
(gnus-treat-strip-pem gnus-article-hide-pem)
+ (gnus-treat-from-picon gnus-treat-from-picon)
+ (gnus-treat-mail-picon gnus-treat-mail-picon)
+ (gnus-treat-newsgroups-picon gnus-treat-newsgroups-picon)
(gnus-treat-highlight-headers gnus-article-highlight-headers)
(gnus-treat-highlight-citation gnus-article-highlight-citation)
(gnus-treat-highlight-signature gnus-article-highlight-signature)
- (gnus-treat-date-ut gnus-article-date-ut)
- (gnus-treat-date-local gnus-article-date-local)
- (gnus-treat-date-lapsed gnus-article-date-lapsed)
- (gnus-treat-date-original gnus-article-date-original)
- (gnus-treat-date-user-defined gnus-article-date-user)
- (gnus-treat-date-iso8601 gnus-article-date-iso8601)
(gnus-treat-strip-trailing-blank-lines
gnus-article-remove-trailing-blank-lines)
(gnus-treat-strip-leading-blank-lines
(gnus-treat-strip-multiple-blank-lines
gnus-article-strip-multiple-blank-lines)
(gnus-treat-overstrike gnus-article-treat-overstrike)
+ (gnus-treat-unfold-headers gnus-article-treat-unfold-headers)
(gnus-treat-buttonize-head gnus-article-add-buttons-to-head)
(gnus-treat-display-smileys gnus-smiley-display)
(gnus-treat-capitalize-sentences gnus-article-capitalize-sentences)
- (gnus-treat-display-picons gnus-article-display-picons)
+ (gnus-treat-emphasize gnus-article-emphasize)
+ (gnus-treat-body-boundary gnus-article-treat-body-boundary)
(gnus-treat-play-sounds gnus-earcon-display)))
(defvar gnus-article-mime-handle-alist nil)
(defvar gnus-article-mode-syntax-table
(let ((table (copy-syntax-table text-mode-syntax-table)))
;; This causes the citation match run O(2^n).
- ;; (modify-syntax-entry ?- "w" table)
+ ;; (modify-syntax-entry ?- "w" table)
(modify-syntax-entry ?> ")" table)
(modify-syntax-entry ?< "(" table)
table)
(defvar gnus-inhibit-hiding nil)
+;;; Macros for dealing with the article buffer.
+
+(defmacro gnus-with-article-headers (&rest forms)
+ `(save-excursion
+ (set-buffer gnus-article-buffer)
+ (save-restriction
+ (let ((buffer-read-only nil)
+ (inhibit-point-motion-hooks t)
+ (case-fold-search t))
+ (article-narrow-to-head)
+ ,@forms))))
+
+(put 'gnus-with-article-headers 'lisp-indent-function 0)
+(put 'gnus-with-article-headers 'edebug-form-spec '(body))
+
(defsubst gnus-article-hide-text (b e props)
"Set text PROPS on the B to E region, extending `intangible' 1 past B."
(gnus-add-text-properties-when 'article-type nil b e props)
;; `gnus-ignored-headers' and `gnus-visible-headers' to
;; select which header lines is to remain visible in the
;; article buffer.
- (while (re-search-forward "^[^ \t]*:" nil t)
+ (while (re-search-forward "^[^ \t:]*:" nil t)
(beginning-of-line)
;; Mark the rank of the header.
(put-text-property
'boring-headers)))
;; Hide boring Newsgroups header.
((eq elem 'newsgroups)
- (when (equal (gnus-fetch-field "newsgroups")
- (gnus-group-real-name
- (if (boundp 'gnus-newsgroup-name)
- gnus-newsgroup-name
- "")))
+ (when (gnus-string-equal
+ (gnus-fetch-field "newsgroups")
+ (gnus-group-real-name
+ (if (boundp 'gnus-newsgroup-name)
+ gnus-newsgroup-name
+ "")))
(gnus-article-hide-header "newsgroups")))
+ ((eq elem 'to-address)
+ (let ((to (message-fetch-field "to"))
+ (to-address
+ (gnus-parameter-to-address
+ (if (boundp 'gnus-newsgroup-name)
+ gnus-newsgroup-name ""))))
+ (when (and to to-address
+ (ignore-errors
+ (gnus-string-equal
+ ;; only one address in To
+ (nth 1 (mail-extract-address-components to))
+ to-address)))
+ (gnus-article-hide-header "to"))))
((eq elem 'followup-to)
- (when (equal (message-fetch-field "followup-to")
- (message-fetch-field "newsgroups"))
+ (when (gnus-string-equal
+ (message-fetch-field "followup-to")
+ (message-fetch-field "newsgroups"))
(gnus-article-hide-header "followup-to")))
((eq elem 'reply-to)
(let ((from (message-fetch-field "from"))
(when (and
from reply-to
(ignore-errors
- (equal
+ (gnus-string-equal
(nth 1 (mail-extract-address-components from))
(nth 1 (mail-extract-address-components reply-to)))))
(gnus-article-hide-header "reply-to"))))
(put-text-property
(point) (1+ (point)) 'face 'underline)))))))))
+(defun gnus-article-treat-unfold-headers ()
+ "Unfold folded message headers.
+Only the headers that fit into the current window width will be
+unfolded."
+ (interactive)
+ (gnus-with-article-headers
+ (let (length)
+ (while (not (eobp))
+ (save-restriction
+ (mail-header-narrow-to-field)
+ (let ((header (buffer-substring (point-min) (point-max))))
+ (with-temp-buffer
+ (insert header)
+ (goto-char (point-min))
+ (while (re-search-forward "[\t ]*\n[\t ]+" nil t)
+ (replace-match " " t t)))
+ (setq length (- (point-max) (point-min) 1)))
+ (when (< length (window-width))
+ (while (re-search-forward "[\t ]*\n[\t ]+" nil t)
+ (replace-match " " t t)))
+ (goto-char (point-max)))))))
+
+(defun gnus-article-treat-body-boundary ()
+ "Place a boundary line at the end of the headers."
+ (interactive)
+ (gnus-with-article-headers
+ (goto-char (point-max))
+ (let ((start (point)))
+ (insert "X-Boundary: ")
+ (gnus-add-text-properties start (point) '(invisible t intangible t))
+ (insert (make-string (1- (window-width)) ?-)
+ "\n")
+ ;;(put-text-property (point) (progn (forward-line -1) (point))
+ ;; 'face 'gnus-body-bondary-face)
+ )))
+
(defun article-fill-long-lines ()
"Fill lines that are wider than the window width."
(interactive)
(width (window-width (get-buffer-window (current-buffer)))))
(save-restriction
(article-goto-body)
- (let ((adaptive-fill-mode nil))
+ (let ((adaptive-fill-mode nil)) ;Why? -sm
(while (not (eobp))
(end-of-line)
(when (>= (current-column) (min fill-column width))
(when (process-status "article-x-face")
(delete-process "article-x-face"))
(let ((inhibit-point-motion-hooks t)
+ x-faces
(case-fold-search t)
from last)
(save-restriction
(article-narrow-to-head)
+ (when (and buffer-read-only ;; When type `W f'
+ (progn
+ (goto-char (point-min))
+ (not (re-search-forward "^X-Face:[\t ]*" nil t)))
+ (gnus-buffer-live-p gnus-original-article-buffer))
+ (with-current-buffer gnus-original-article-buffer
+ (save-restriction
+ (article-narrow-to-head)
+ (while (re-search-forward "^X-Face:" nil t)
+ (setq x-faces
+ (concat
+ (or x-faces "")
+ (buffer-substring
+ (match-beginning 0)
+ (1- (re-search-forward
+ "^\\($\\|[^ \t]\\)" nil t))))))))
+ (if x-faces
+ (let (point start bface eface buffer-read-only)
+ (goto-char (point-max))
+ (forward-line -1)
+ (setq bface (get-text-property (gnus-point-at-bol) 'face)
+ eface (get-text-property (1- (gnus-point-at-eol)) 'face))
+ (goto-char (point-max))
+ (setq point (point))
+ (insert x-faces)
+ (goto-char point)
+ (while (looking-at "\\([^:]+\\): *")
+ (put-text-property (match-beginning 1) (1+ (match-end 1))
+ 'face bface)
+ (setq start (match-end 0))
+ (forward-line 1)
+ (while (looking-at "[\t ]")
+ (forward-line 1))
+ (put-text-property start (point)
+ 'face eface)))))
(goto-char (point-min))
(setq from (message-fetch-field "from"))
(goto-char (point-min))
(not (string-match gnus-article-x-face-too-ugly
from))))
;; Has to be present.
- (re-search-forward "^X-Face: " nil t))
+ (re-search-forward "^X-Face:[\t ]*" 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
;; We now have the area of the buffer where the X-Face is stored.
(save-excursion
(let ((beg (point))
- (end (1- (re-search-forward "^\\($\\|[^ \t]\\)" nil t))))
+ (end (1- (re-search-forward "^\\($\\|[^ \t]\\)" nil t)))
+ buffer-read-only)
;; We display the face.
(if (symbolp gnus-article-x-face-command)
;; The command is a lisp function, so we call it.
(let ((inhibit-point-motion-hooks t)
buffer-read-only
(mail-parse-charset gnus-newsgroup-charset)
- (mail-parse-ignored-charsets
+ (mail-parse-ignored-charsets
(save-excursion (set-buffer gnus-summary-buffer)
gnus-newsgroup-ignored-charsets)))
(mail-decode-encoded-word-region (point-min) (point-max)))))
(let ((inhibit-point-motion-hooks t) (case-fold-search t)
buffer-read-only
(mail-parse-charset gnus-newsgroup-charset)
- (mail-parse-ignored-charsets
+ (mail-parse-ignored-charsets
(save-excursion (condition-case nil
(set-buffer gnus-summary-buffer)
(error))
format (and ctl (mail-content-type-get ctl 'format)))
(when cte
(setq cte (mail-header-strip cte)))
- (if (and ctl (not (string-match "/" (car ctl))))
+ (if (and ctl (not (string-match "/" (car ctl))))
(setq ctl nil))
(goto-char (point-max)))
(forward-line 1)
"Remove encoded-word encoding from headers."
(let ((inhibit-point-motion-hooks t)
(mail-parse-charset gnus-newsgroup-charset)
- (mail-parse-ignored-charsets
+ (mail-parse-ignored-charsets
(save-excursion (condition-case nil
(set-buffer gnus-summary-buffer)
(error))
(article-narrow-to-head)
(funcall gnus-decode-header-function (point-min) (point-max)))))
-(defun article-de-quoted-unreadable (&optional force)
+(defun article-decode-group-name ()
+ "Decode group names in `Newsgroups:'."
+ (let ((inhibit-point-motion-hooks t)
+ buffer-read-only
+ (method (gnus-find-method-for-group gnus-newsgroup-name)))
+ (when (and (or gnus-group-name-charset-method-alist
+ gnus-group-name-charset-group-alist)
+ (gnus-buffer-live-p gnus-original-article-buffer))
+ (when (nnmail-fetch-field "Newsgroups")
+ (nnheader-replace-header "Newsgroups"
+ (gnus-decode-newsgroups
+ (with-current-buffer
+ gnus-original-article-buffer
+ (nnmail-fetch-field "Newsgroups"))
+ gnus-newsgroup-name method)))
+ (when (nnmail-fetch-field "Followup-To")
+ (nnheader-replace-header "Followup-To"
+ (gnus-decode-newsgroups
+ (with-current-buffer
+ gnus-original-article-buffer
+ (nnmail-fetch-field "Followup-To"))
+ gnus-newsgroup-name method))))))
+
+(defun article-de-quoted-unreadable (&optional force read-charset)
"Translate a quoted-printable-encoded article.
If FORCE, decode the article whether it is marked as quoted-printable
-or not."
- (interactive (list 'force))
+or not.
+If READ-CHARSET, ask for a coding system."
+ (interactive (list 'force current-prefix-arg))
(save-excursion
(let ((buffer-read-only nil) type charset)
(if (gnus-buffer-live-p gnus-original-article-buffer)
(setq type
(gnus-fetch-field "content-transfer-encoding"))
(let* ((ct (gnus-fetch-field "content-type"))
- (ctl (and ct
+ (ctl (and ct
(ignore-errors
(mail-header-parse-content-type ct)))))
(setq charset (and ctl
(mail-content-type-get ctl 'charset)))
(if (stringp charset)
(setq charset (intern (downcase charset)))))))
- (unless charset
+ (if read-charset
+ (setq charset (mm-read-coding-system "Charset: " charset)))
+ (unless charset
(setq charset gnus-newsgroup-charset))
(when (or force
(and type (let ((case-fold-search t))
(quoted-printable-decode-region
(point) (point-max) (mm-charset-to-coding-system charset))))))
-(defun article-de-base64-unreadable (&optional force)
+(defun article-de-base64-unreadable (&optional force read-charset)
"Translate a base64 article.
-If FORCE, decode the article whether it is marked as base64 not."
- (interactive (list 'force))
+If FORCE, decode the article whether it is marked as base64 not.
+If READ-CHARSET, ask for a coding system."
+ (interactive (list 'force current-prefix-arg))
(save-excursion
(let ((buffer-read-only nil) type charset)
(if (gnus-buffer-live-p gnus-original-article-buffer)
(setq type
(gnus-fetch-field "content-transfer-encoding"))
(let* ((ct (gnus-fetch-field "content-type"))
- (ctl (and ct
+ (ctl (and ct
(ignore-errors
(mail-header-parse-content-type ct)))))
(setq charset (and ctl
(mail-content-type-get ctl 'charset)))
(if (stringp charset)
(setq charset (intern (downcase charset)))))))
- (unless charset
+ (if read-charset
+ (setq charset (mm-read-coding-system "Charset: " charset)))
+ (unless charset
(setq charset gnus-newsgroup-charset))
(when (or force
(and type (let ((case-fold-search t))
(let ((buffer-read-only nil))
(rfc1843-decode-region (point-min) (point-max)))))
-(defun article-wash-html ()
- "Format an html article."
- (interactive)
+(defun article-wash-html (&optional read-charset)
+ "Format an html article.
+If READ-CHARSET, ask for a coding system."
+ (interactive "P")
(save-excursion
(let ((buffer-read-only nil)
charset)
(if (gnus-buffer-live-p gnus-original-article-buffer)
(with-current-buffer gnus-original-article-buffer
(let* ((ct (gnus-fetch-field "content-type"))
- (ctl (and ct
+ (ctl (and ct
(ignore-errors
(mail-header-parse-content-type ct)))))
(setq charset (and ctl
(mail-content-type-get ctl 'charset)))
(if (stringp charset)
(setq charset (intern (downcase charset)))))))
- (unless charset
+ (if read-charset
+ (setq charset (mm-read-coding-system "Charset: " charset)))
+ (unless charset
(setq charset gnus-newsgroup-charset))
(article-goto-body)
(save-window-excursion
(narrow-to-region (point) (point-max))
(mm-setup-w3)
(let ((w3-strict-width (window-width))
- (url-standalone-mode t))
+ (url-standalone-mode t)
+ (w3-honor-stylesheets nil)
+ (w3-delay-image-loads t))
(condition-case var
(w3-region (point-min) (point-max))
(error))))))))
"Remove list identifies from the Subject header.
The `gnus-list-identifiers' variable specifies what to do."
(interactive)
- (save-excursion
- (save-restriction
- (let ((inhibit-point-motion-hooks t)
- buffer-read-only)
- (article-narrow-to-head)
- (let ((regexp (if (stringp gnus-list-identifiers) gnus-list-identifiers
- (mapconcat 'identity gnus-list-identifiers " *\\|"))))
- (when regexp
- (goto-char (point-min))
- (when (re-search-forward
- (concat "^Subject: +\\(\\(\\(Re: +\\)?\\(" regexp
- " *\\)\\)+\\(Re: +\\)?\\)")
- nil t)
- (let ((s (or (match-string 3) (match-string 5))))
- (delete-region (match-beginning 1) (match-end 1))
- (when s
- (goto-char (match-beginning 1))
- (insert s))))))))))
+ (let ((inhibit-point-motion-hooks t)
+ (regexp (if (consp gnus-list-identifiers)
+ (mapconcat 'identity gnus-list-identifiers " *\\|")
+ gnus-list-identifiers))
+ buffer-read-only)
+ (when regexp
+ (save-excursion
+ (save-restriction
+ (article-narrow-to-head)
+ (goto-char (point-min))
+ (while (re-search-forward
+ (concat "^Subject: +\\(R[Ee]: +\\)*\\(" regexp " *\\)")
+ nil t)
+ (delete-region (match-beginning 2) (match-end 0))
+ (beginning-of-line))
+ (when (re-search-forward
+ "^Subject: +\\(\\(R[Ee]: +\\)+\\)R[Ee]: +" nil t)
+ (delete-region (match-beginning 1) (match-end 1))))))))
(defun article-hide-pgp ()
"Remove any PGP headers and signatures in the current article."
(save-excursion
(save-restriction
(let ((inhibit-point-motion-hooks t)
- (banner (gnus-group-find-parameter gnus-newsgroup-name 'banner))
+ (banner (gnus-parameter-banner gnus-newsgroup-name))
(gnus-signature-limit nil)
buffer-read-only beg end)
(when banner
(start (point))
(end (point-max))
(orig (buffer-substring start end))
- (trans (babel-as-string orig)))
+ (trans (babel-as-string orig)))
(save-restriction
(narrow-to-region start end)
(delete-region start end)
- (insert trans))))))
+ (insert trans))))))
(defun article-hide-signature (&optional arg)
"Hide the signature in the current article.
(let ((buffer-read-only nil))
(when (gnus-article-narrow-to-signature)
(gnus-article-hide-text-type
- (point-min) (point-max) 'signature)))))))
+ (point-min) (point-max) 'signature))))))
+ (gnus-set-mode-line 'article))
(defun article-strip-headers-in-body ()
"Strip offensive headers from bodies."
(replace-match "" nil t)))
;; Then replace multiple empty lines with a single empty line.
(article-goto-body)
- (while (re-search-forward "\n\n\n+" nil t)
+ (while (re-search-forward "\n\n\\(\n+\\)" nil t)
(unless (gnus-annotation-in-region-p
(match-beginning 0) (match-end 0))
- (replace-match "\n\n" t t))))))
+ (delete-region (match-beginning 1) (match-end 1)))))))
(defun article-strip-leading-space ()
"Remove all white space from the beginning of the lines in the article."
(defun gnus-article-check-hidden-text (type arg)
"Return nil if hiding is necessary.
-Arg can be nil or a number. Nil and positive means hide, negative
+Arg can be nil or a number. nil and positive means hide, negative
means show, 0 means toggle."
(save-excursion
(save-restriction
Originally it is hide instead of DUMMY."
(let ((buffer-read-only nil)
(inhibit-point-motion-hooks t))
- (gnus-remove-text-properties-when
+ (gnus-remove-text-properties-when
'article-type type
- (point-min) (point-max)
+ (point-min) (point-max)
(cons 'article-type (cons type
- gnus-hidden-properties)))))
+ gnus-hidden-properties)))
+ (setq gnus-article-wash-types (delq type gnus-article-wash-types))))
(defconst article-time-units
`((year . ,(* 365.25 24 60 60))
(message-fetch-field "date")
""))
(tdate-regexp "^Date:[ \t]\\|^X-Sent:[ \t]")
- (date-regexp
+ (date-regexp
(cond
((not gnus-article-date-lapsed-new-header)
tdate-regexp)
(when (and date (not (string= date "")))
(goto-char (point-min))
(let ((buffer-read-only nil))
- ;; Delete any old Date headers.
- (while (re-search-forward date-regexp nil t)
+ ;; Delete any old Date headers.
+ (while (re-search-forward date-regexp nil t)
(if pos
(delete-region (progn (beginning-of-line) (point))
(progn (forward-line 1) (point)))
(defun article-make-date-line (date type)
"Return a DATE line of TYPE."
- (let ((time (condition-case ()
- (date-to-time date)
- (error '(0 0)))))
- (cond
- ;; Convert to the local timezone. We have to slap a
- ;; `condition-case' round the calls to the timezone
- ;; functions since they aren't particularly resistant to
- ;; buggy dates.
- ((eq type 'local)
- (let ((tz (car (current-time-zone time))))
- (format "Date: %s %s%02d%02d" (current-time-string time)
- (if (> tz 0) "+" "-") (/ (abs tz) 3600)
- (/ (% (abs tz) 3600) 60))))
- ;; Convert to Universal Time.
- ((eq type 'ut)
- (concat "Date: "
- (current-time-string
- (let* ((e (parse-time-string date))
- (tm (apply 'encode-time e))
- (ms (car tm))
- (ls (- (cadr tm) (car (current-time-zone time)))))
- (cond ((< ls 0) (list (1- ms) (+ ls 65536)))
- ((> ls 65535) (list (1+ ms) (- ls 65536)))
- (t (list ms ls)))))
- " UT"))
- ;; Get the original date from the article.
- ((eq type 'original)
- (concat "Date: " (if (string-match "\n+$" date)
- (substring date 0 (match-beginning 0))
- date)))
- ;; Let the user define the format.
- ((eq type 'user)
- (if (gnus-functionp gnus-article-time-format)
- (funcall gnus-article-time-format time)
- (concat
- "Date: "
- (format-time-string gnus-article-time-format time))))
- ;; ISO 8601.
- ((eq type 'iso8601)
- (let ((tz (car (current-time-zone time))))
- (concat
- "Date: "
- (format-time-string "%Y%m%dT%H%M%S" time)
- (format "%s%02d%02d"
- (if (> tz 0) "+" "-") (/ (abs tz) 3600)
- (/ (% (abs tz) 3600) 60)))))
- ;; 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 (subtract-time now time))
- (real-sec (and real-time
- (+ (* (float (car real-time)) 65536)
- (cadr real-time))))
- (sec (and real-time (abs real-sec)))
- num prev)
+ (unless (memq type '(local ut original user iso8601 lapsed english))
+ (error "Unknown conversion type: %s" type))
+ (condition-case ()
+ (let ((time (date-to-time date)))
(cond
- ((null real-time)
- "X-Sent: Unknown")
- ((zerop sec)
- "X-Sent: Now")
- (t
- (concat
- "X-Sent: "
- ;; This is a bit convoluted, but basically we go
- ;; through the time units for years, weeks, etc,
- ;; and divide things to see whether that results
- ;; in positive answers.
- (mapconcat
- (lambda (unit)
- (if (zerop (setq num (ffloor (/ sec (cdr unit)))))
- ;; The (remaining) seconds are too few to
- ;; be divided into this time unit.
- ""
- ;; It's big enough, so we output it.
- (setq sec (- sec (* num (cdr unit))))
- (prog1
- (concat (if prev ", " "") (int-to-string
- (floor num))
- " " (symbol-name (car unit))
- (if (> num 1) "s" ""))
- (setq prev t))))
- article-time-units "")
- ;; If dates are odd, then it might appear like the
- ;; article was sent in the future.
- (if (> real-sec 0)
- " ago"
- " in the future"))))))
- (t
- (error "Unknown conversion type: %s" type)))))
+ ;; Convert to the local timezone.
+ ((eq type 'local)
+ (let ((tz (car (current-time-zone time))))
+ (format "Date: %s %s%02d%02d" (current-time-string time)
+ (if (> tz 0) "+" "-") (/ (abs tz) 3600)
+ (/ (% (abs tz) 3600) 60))))
+ ;; Convert to Universal Time.
+ ((eq type 'ut)
+ (concat "Date: "
+ (current-time-string
+ (let* ((e (parse-time-string date))
+ (tm (apply 'encode-time e))
+ (ms (car tm))
+ (ls (- (cadr tm) (car (current-time-zone time)))))
+ (cond ((< ls 0) (list (1- ms) (+ ls 65536)))
+ ((> ls 65535) (list (1+ ms) (- ls 65536)))
+ (t (list ms ls)))))
+ " UT"))
+ ;; Get the original date from the article.
+ ((eq type 'original)
+ (concat "Date: " (if (string-match "\n+$" date)
+ (substring date 0 (match-beginning 0))
+ date)))
+ ;; Let the user define the format.
+ ((eq type 'user)
+ (if (gnus-functionp gnus-article-time-format)
+ (funcall gnus-article-time-format time)
+ (concat
+ "Date: "
+ (format-time-string gnus-article-time-format time))))
+ ;; ISO 8601.
+ ((eq type 'iso8601)
+ (let ((tz (car (current-time-zone time))))
+ (concat
+ "Date: "
+ (format-time-string "%Y%m%dT%H%M%S" time)
+ (format "%s%02d%02d"
+ (if (> tz 0) "+" "-") (/ (abs tz) 3600)
+ (/ (% (abs tz) 3600) 60)))))
+ ;; 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 (subtract-time now time))
+ (real-sec (and real-time
+ (+ (* (float (car real-time)) 65536)
+ (cadr real-time))))
+ (sec (and real-time (abs real-sec)))
+ num prev)
+ (cond
+ ((null real-time)
+ "X-Sent: Unknown")
+ ((zerop sec)
+ "X-Sent: Now")
+ (t
+ (concat
+ "X-Sent: "
+ ;; This is a bit convoluted, but basically we go
+ ;; through the time units for years, weeks, etc,
+ ;; and divide things to see whether that results
+ ;; in positive answers.
+ (mapconcat
+ (lambda (unit)
+ (if (zerop (setq num (ffloor (/ sec (cdr unit)))))
+ ;; The (remaining) seconds are too few to
+ ;; be divided into this time unit.
+ ""
+ ;; It's big enough, so we output it.
+ (setq sec (- sec (* num (cdr unit))))
+ (prog1
+ (concat (if prev ", " "") (int-to-string
+ (floor num))
+ " " (symbol-name (car unit))
+ (if (> num 1) "s" ""))
+ (setq prev t))))
+ article-time-units "")
+ ;; If dates are odd, then it might appear like the
+ ;; article was sent in the future.
+ (if (> real-sec 0)
+ " ago"
+ " in the future"))))))
+ ;; Display the date in proper English
+ ((eq type 'english)
+ (let ((dtime (decode-time time)))
+ (concat
+ "Date: the "
+ (number-to-string (nth 3 dtime))
+ (let ((digit (% (nth 3 dtime) 10)))
+ (cond
+ ((memq (nth 3 dtime) '(11 12 13)) "th")
+ ((= digit 1) "st")
+ ((= digit 2) "nd")
+ ((= digit 3) "rd")
+ (t "th")))
+ " of "
+ (nth (1- (nth 4 dtime)) gnus-english-month-names)
+ " "
+ (number-to-string (nth 5 dtime))
+ " at "
+ (format "%02d" (nth 2 dtime))
+ ":"
+ (format "%02d" (nth 1 dtime)))))))
+ (error
+ (format "Date: %s (from Oort)" date))))
(defun article-date-local&n
projects / gnus / blobdiff