;;; Code:
+(eval-when-compile (require 'cl))
+
(require 'custom)
(require 'gnus)
(require 'gnus-sum)
'("^Path:" "^Posting-Version:" "^Article-I.D.:" "^Expires:"
"^Date-Received:" "^References:" "^Control:" "^Xref:" "^Lines:"
"^Posted:" "^Relay-Version:" "^Message-ID:" "^Nf-ID:" "^Nf-From:"
- "^Approved:" "^Sender:" "^Received:" "^Mail-from:")
- "All headers that match this regexp will be hidden.
+ "^Approved:" "^Sender:" "^Received:" "^Mail-from:")
+ "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
(repeat regexp))
: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-"
+(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"
"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."
:group 'gnus-article-hiding)
(defcustom gnus-sorted-header-list
- '("^From:" "^Subject:" "^Summary:" "^Keywords:" "^Newsgroups:" "^To:"
- "^Cc:" "^Date:" "^Organization:")
+ '("^From:" "^Subject:" "^Summary:" "^Keywords:" "^Newsgroups:"
+ "^Followup-To:" "^To:" "^Cc:" "^Date:" "^Organization:")
"This variable is a list of regular expressions.
If it is non-nil, headers that match the regular expressions will
be placed first in the article buffer in the sequence specified by
(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))
:group 'gnus-article-hiding)
(defcustom gnus-signature-separator '("^-- $" "^-- *$")
(defcustom gnus-hidden-properties '(invisible t intangible t)
"Property list to use for hiding text."
- :type 'sexp
+ :type 'sexp
:group 'gnus-article-hiding)
(defcustom gnus-article-x-face-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
(let ((format
- "\\(\\s-\\|^\\|[-\"\(]\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\s-\\|[-?!.,;:\"\)]\\)")
+ "\\(\\s-\\|^\\|[-\"]\\|\\s(\\|\\s)\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\s-\\|[-?!.,;:\"]\\|\\s(\\|\\s)\\)")
(types
'(("_" "_" underline)
("/" "/" italic)
"Face used for displaying bold italic emphasized text (/*word*/)."
:group 'gnus-article-emphasis)
-(defface gnus-emphasis-underline-bold-italic
+(defface gnus-emphasis-underline-bold-italic
'((t (:bold t :italic t :underline t)))
"Face used for displaying underlined bold italic emphasized text.
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)
(autoload 'timezone-make-date-arpa-standard "timezone")
(autoload 'mail-extract-address-components "mail-extr"))
-(defcustom gnus-article-save-directory gnus-directory
- "*Name of the directory articles will be saved in (default \"~/News\")."
- :group 'gnus-article-saving
- :type 'directory)
-
(defcustom gnus-save-all-headers t
"*If non-nil, don't remove any headers before saving."
:group 'gnus-article-saving
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.
:type 'function)
(defcustom gnus-split-methods
- '((gnus-article-archive-name))
+ '((gnus-article-archive-name)
+ (gnus-article-nndoc-name))
"Variable used to suggest where articles are to be saved.
For instance, if you would like to save articles related to Gnus in
the file \"gnus-stuff\", and articles related to VM in \"vm-stuff\",
:type 'hook
:group 'gnus-article-various)
+(defcustom gnus-article-hide-pgp-hook nil
+ "*A hook called after successfully hiding a PGP signature."
+ :type 'hook
+ :group 'gnus-article-various)
+
(defcustom gnus-article-button-face 'bold
"Face used for highlighting buttons in the article buffer.
:type 'face
:group 'gnus-article-buttons)
-(defcustom gnus-signature-face 'italic
- "Face used for highlighting a signature in the article buffer."
+(defcustom gnus-signature-face 'gnus-signature-face
+ "Face used for highlighting a signature in the article buffer.
+Obsolete; use the face `gnus-signature-face' for customizations instead."
:type 'face
:group 'gnus-article-highlight
:group 'gnus-article-signature)
-(defface gnus-header-from-face
+(defface gnus-signature-face
+ '((((type x))
+ (:italic t)))
+ "Face used for highlighting a signature in the article buffer."
+ :group 'gnus-article-highlight
+ :group 'gnus-article-signature)
+
+(defface gnus-header-from-face
'((((class color)
(background dark))
- (:foreground "light blue" :bold t :italic t))
+ (:foreground "spring green" :bold t))
(((class color)
(background light))
- (:foreground "MidnightBlue" :bold t :italic t))
- (t
+ (:foreground "red3" :bold t))
+ (t
(:bold t :italic t)))
"Face used for displaying from headers."
:group 'gnus-article-headers
:group 'gnus-article-highlight)
-(defface gnus-header-subject-face
+(defface gnus-header-subject-face
'((((class color)
(background dark))
- (:foreground "pink" :bold t :italic t))
+ (:foreground "SeaGreen3" :bold t))
(((class color)
(background light))
- (:foreground "firebrick" :bold t :italic t))
- (t
+ (:foreground "red4" :bold t))
+ (t
(:bold t :italic t)))
"Face used for displaying subject headers."
:group 'gnus-article-headers
:group 'gnus-article-highlight)
-(defface gnus-header-newsgroups-face
+(defface gnus-header-newsgroups-face
'((((class color)
(background dark))
(:foreground "yellow" :bold t :italic t))
(((class color)
(background light))
- (:foreground "indianred" :bold t :italic t))
- (t
+ (:foreground "MidnightBlue" :bold t :italic t))
+ (t
(:bold t :italic t)))
"Face used for displaying newsgroups headers."
:group 'gnus-article-headers
:group 'gnus-article-highlight)
-(defface gnus-header-name-face
+(defface gnus-header-name-face
'((((class color)
(background dark))
- (:foreground "cyan" :bold t))
+ (:foreground "SeaGreen"))
(((class color)
(background light))
- (:foreground "DarkGreen" :bold t))
- (t
+ (:foreground "maroon"))
+ (t
(:bold t)))
"Face used for displaying header names."
:group 'gnus-article-headers
(:foreground "forest green" :italic t))
(((class color)
(background light))
- (:foreground "DarkGreen" :italic t))
- (t
+ (:foreground "indianred4" :italic t))
+ (t
(:italic t))) "Face used for displaying header content."
:group 'gnus-article-headers
:group 'gnus-article-highlight)
("" gnus-header-name-face gnus-header-content-face))
"Controls highlighting of article header.
-An alist of the form (HEADER NAME CONTENT).
+An alist of the form (HEADER NAME CONTENT).
HEADER is a regular expression which should match the name of an
header header and NAME and CONTENT are either face names or nil.
(defvar gnus-article-mode-syntax-table
(let ((table (copy-syntax-table text-mode-syntax-table)))
- ;;(modify-syntax-entry ?_ "w" table)
+ (modify-syntax-entry ?- "w" table)
+ (modify-syntax-entry ?> ")" table)
+ (modify-syntax-entry ?< "(" table)
table)
"Syntax table used in article mode buffers.
Initialized from `text-mode-syntax-table.")
(defvar gnus-number-of-articles-to-be-saved nil)
(defvar gnus-inhibit-hiding nil)
-(defvar gnus-newsgroup-name)
(defsubst gnus-article-hide-text (b e props)
"Set text PROPS on the B to E region, extending `intangible' 1 past B."
(add-text-properties b e props)
(when (memq 'intangible props)
- (put-text-property
+ (put-text-property
(max (1- b) (point-min))
b 'intangible (cddr (memq 'intangible props)))))
(save-excursion
(let ((b (point-min)))
(while (setq b (text-property-any b (point-max) 'article-type type))
- (delete-region b (incf b))))))
+ (delete-region
+ 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."
(save-excursion
(let ((b (point-min)))
(while (setq b (text-property-any b (point-max) 'invisible t))
- (delete-region b (incf b))))))
+ (delete-region
+ 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."
(while (re-search-forward "^[^ \t]*:" nil t)
(beginning-of-line)
;; Mark the rank of the header.
- (put-text-property
+ (put-text-property
(point) (1+ (point)) 'message-rank
(if (or (and visible (looking-at visible))
(and ignored
(not (looking-at ignored))))
- (gnus-article-header-rank)
+ (gnus-article-header-rank)
(+ 2 max)))
(forward-line 1))
(message-sort-headers-1)
- (when (setq beg (text-property-any
+ (when (setq beg (text-property-any
(point-min) (point-max) 'message-rank (+ 2 max)))
;; We make the unwanted headers invisible.
(if delete
(forward-line -1)
(gnus-article-hide-text-type
(progn (beginning-of-line) (point))
- (progn
+ (progn
(end-of-line)
(if (re-search-forward "^[^ \t]" nil t)
(match-beginning 0)
(when (and
from reply-to
(ignore-errors
- (equal
+ (equal
(nth 1 (mail-extract-address-components from))
(nth 1 (mail-extract-address-components reply-to)))))
(gnus-article-hide-header "reply-to"))))
(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")))))))))))
(defun gnus-article-hide-header (header)
(save-excursion
(when (re-search-forward (concat "^" header ":") nil t)
(gnus-article-hide-text-type
(progn (beginning-of-line) (point))
- (progn
+ (progn
(end-of-line)
(if (re-search-forward "^[^ \t]" nil t)
(match-beginning 0)
"Translate overstrikes into bold text."
(interactive)
(save-excursion
- (let ((buffer-read-only nil))
- (while (search-forward "\b" nil t)
- (let ((next (following-char))
- (previous (char-after (- (point) 2))))
- ;; We do the boldification/underlining by hiding the
- ;; overstrikes and putting the proper text property
- ;; on the letters.
- (cond
- ((eq next previous)
- (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike)
- (put-text-property (point) (1+ (point)) 'face 'bold))
- ((eq next ?_)
- (gnus-article-hide-text-type (1- (point)) (1+ (point)) 'overstrike)
- (put-text-property
- (- (point) 2) (1- (point)) 'face 'underline))
- ((eq previous ?_)
- (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike)
- (put-text-property
- (point) (1+ (point)) 'face 'underline))))))))
+ (goto-char (point-min))
+ (when (search-forward "\n\n" nil t)
+ (let ((buffer-read-only nil))
+ (while (search-forward "\b" nil t)
+ (let ((next (following-char))
+ (previous (char-after (- (point) 2))))
+ ;; We do the boldification/underlining by hiding the
+ ;; overstrikes and putting the proper text property
+ ;; on the letters.
+ (cond
+ ((eq next previous)
+ (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike)
+ (put-text-property (point) (1+ (point)) 'face 'bold))
+ ((eq next ?_)
+ (gnus-article-hide-text-type
+ (1- (point)) (1+ (point)) 'overstrike)
+ (put-text-property
+ (- (point) 2) (1- (point)) 'face 'underline))
+ ((eq previous ?_)
+ (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike)
+ (put-text-property
+ (point) (1+ (point)) 'face 'underline)))))))))
(defun article-fill ()
"Format too long lines."
(nnheader-narrow-to-headers)
(setq from (message-fetch-field "from"))
(goto-char (point-min))
- (when (and gnus-article-x-face-command
- (or force
- ;; Check whether this face is censored.
- (not gnus-article-x-face-too-ugly)
- (and gnus-article-x-face-too-ugly from
- (not (string-match gnus-article-x-face-too-ugly
- from))))
- ;; Has to be present.
- (re-search-forward "^X-Face: " nil t))
+ (while (and gnus-article-x-face-command
+ (or force
+ ;; Check whether this face is censored.
+ (not gnus-article-x-face-too-ugly)
+ (and gnus-article-x-face-too-ugly from
+ (not (string-match gnus-article-x-face-too-ugly
+ from))))
+ ;; Has to be present.
+ (re-search-forward "^X-Face: " nil t))
;; We now have the area of the buffer where the X-Face is stored.
- (let ((beg (point))
- (end (1- (re-search-forward "^\\($\\|[^ \t]\\)" nil t))))
- ;; We display the face.
- (if (symbolp gnus-article-x-face-command)
- ;; The command is a lisp function, so we call it.
- (if (gnus-functionp gnus-article-x-face-command)
- (funcall gnus-article-x-face-command beg end)
- (error "%s is not a function" gnus-article-x-face-command))
- ;; The command is a string, so we interpret the command
- ;; as a, well, command, and fork it off.
- (let ((process-connection-type nil))
- (process-kill-without-query
- (start-process
- "article-x-face" nil shell-file-name shell-command-switch
- gnus-article-x-face-command))
- (process-send-region "article-x-face" beg end)
- (process-send-eof "article-x-face")))))))))
+ (save-excursion
+ (let ((beg (point))
+ (end (1- (re-search-forward "^\\($\\|[^ \t]\\)" nil t))))
+ ;; We display the face.
+ (if (symbolp gnus-article-x-face-command)
+ ;; The command is a lisp function, so we call it.
+ (if (gnus-functionp gnus-article-x-face-command)
+ (funcall gnus-article-x-face-command beg end)
+ (error "%s is not a function" gnus-article-x-face-command))
+ ;; The command is a string, so we interpret the command
+ ;; as a, well, command, and fork it off.
+ (let ((process-connection-type nil))
+ (process-kill-without-query
+ (start-process
+ "article-x-face" nil shell-file-name shell-command-switch
+ gnus-article-x-face-command))
+ (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)
(goto-char (point-min))
(or (search-forward "\n\n" nil t) (point-max)))
(goto-char (point-min))
- (while (re-search-forward
+ (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
+ (article-mime-decode-quoted-printable
(goto-char (point-min)) (point-max))
(subst-char-in-region (point-min) (point-max) ?_ ? )
(goto-char (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 (point-min))
;; Hide the "header".
(when (search-forward "\n-----BEGIN PGP SIGNED MESSAGE-----\n" nil t)
- (gnus-article-hide-text-type (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))))))
+ (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))))))
(defun article-hide-pem (&optional arg)
"Toggle hiding of any PEM headers and signatures in the current article.
(save-restriction
(let ((buffer-read-only nil))
(when (gnus-article-narrow-to-signature)
- (gnus-article-hide-text-type
+ (gnus-article-hide-text-type
(point-min) (point-max) 'signature)))))))
(defun article-strip-leading-blank-lines ()
"Replace consecutive blank lines with one empty line."
(interactive)
(save-excursion
- (let (buffer-read-only)
+ (let ((inhibit-point-motion-hooks t)
+ buffer-read-only)
;; First make all blank lines empty.
(goto-char (point-min))
+ (search-forward "\n\n" nil t)
(while (re-search-forward "^[ \t]+$" nil t)
(replace-match "" nil t))
;; Then replace multiple empty lines with a single empty line.
(goto-char (point-min))
+ (search-forward "\n\n" nil t)
(while (re-search-forward "\n\n\n+" nil t)
(replace-match "\n\n" t t)))))
+(defun article-strip-leading-space ()
+ "Remove all white space from the beginning of the lines in the article."
+ (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]+" nil t)
+ (replace-match "" t t)))))
+
(defun article-strip-blank-lines ()
"Strip leading, trailing and multiple blank lines."
(interactive)
(narrow-to-region
(funcall (intern "mime::preview-content-info/point-min") pcinfo)
(point-max)))))
-
+
(when (gnus-article-search-signature)
(forward-line 1)
;; Check whether we have some limits to what we consider
(goto-char cur)
nil)))
+(eval-and-compile
+ (autoload 'w3-display "w3-parse")
+ (autoload 'w3-do-setup "w3" "" t)
+ (autoload 'w3-region "w3-display" "" t))
+
+(defun gnus-article-treat-html ()
+ "Render HTML."
+ (interactive)
+ (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)
+ (setq b (point))
+ (point-max))
+ (setq e (point-max)))
+ (nnheader-temp-write nil
+ (insert-buffer-substring gnus-article-buffer b e)
+ (require 'url)
+ (save-window-excursion
+ (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))
+ (widen)
+ (goto-char (point-min))
+ (set-window-start (get-buffer-window (current-buffer)) (point-min))
+ (set-buffer cbuf))))
+
(defun gnus-article-hidden-arg ()
"Return the current prefix arg as a number, or 0 if no prefix."
(list (if current-prefix-arg
Arg can be nil or a number. Nil and positive means hide, negative
means show, 0 means toggle."
(save-excursion
- (let ((hide (gnus-article-hidden-text-p type)))
- (cond
- ((or (null arg)
- (> arg 0))
- nil)
- ((< arg 0)
- (gnus-article-show-hidden-text type))
- (t
- (if (eq hide 'hidden)
- (gnus-article-show-hidden-text type)
- nil))))))
+ (save-restriction
+ (widen)
+ (let ((hide (gnus-article-hidden-text-p type)))
+ (cond
+ ((or (null arg)
+ (> arg 0))
+ nil)
+ ((< arg 0)
+ (gnus-article-show-hidden-text type))
+ (t
+ (if (eq hide 'hidden)
+ (gnus-article-show-hidden-text type)
+ nil)))))))
(defun gnus-article-hidden-text-p (type)
"Say whether the current buffer contains hidden text of type TYPE."
- (let ((pos (text-property-any (point-min) (point-max) 'article-type type)))
- (when pos
- (if (get-text-property pos 'invisible)
- 'hidden
- 'shown))))
+ (let ((start (point-min))
+ (pos (text-property-any (point-min) (point-max) 'article-type type)))
+ (while (and pos
+ (not (get-text-property pos 'invisible)))
+ (setq pos
+ (text-property-any (1+ pos) (point-max) 'article-type type)))
+ (if pos
+ 'hidden
+ 'shown)))
(defun gnus-article-show-hidden-text (type &optional hide)
"Show all hidden text of type TYPE.
If TYPE is `local', convert to local time; if it is `lapsed', output
how much time has lapsed since DATE."
(interactive (list 'ut t))
- (let* ((header (or header
+ (let* ((header (or header
(mail-header-date gnus-current-headers)
(message-fetch-field "date")
""))
(concat "Date: " date "\n"))
;; Let the user define the format.
((eq type 'user)
- (format-time-string gnus-article-time-format
- (ignore-errors
- (gnus-encode-date
- (timezone-make-date-arpa-standard
- date nil "UT")))))
+ (concat
+ "Date: "
+ (format-time-string gnus-article-time-format
+ (ignore-errors
+ (gnus-encode-date
+ (timezone-make-date-arpa-standard
+ date nil "UT"))))
+ "\n"))
;; Do an X-Sent lapsed format.
((eq type 'lapsed)
;; If the date is seriously mangled, the timezone functions are
(prog1
(concat (if prev ", " "") (int-to-string
(floor num))
- " " (symbol-name (car unit))
+ " " (symbol-name (car unit))
(if (> num 1) "s" ""))
(setq prev t))))
article-time-units "")
(article-date-ut 'lapsed highlight))
(defun article-date-user (&optional highlight)
- "Convert the current article date to the user-defined format."
+ "Convert the current article date to the user-defined format.
+This format is defined by the `gnus-article-time-format' variable."
(interactive (list t))
(article-date-ut 'user highlight))
(gnus-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.
(when (eq gnus-prompt-before-saving t)
num))) ; Magic
(set-buffer gnus-summary-buffer)
- (funcall gnus-default-article-saver filename)))))
+ (funcall gnus-default-article-saver filename)))))
-(defun gnus-read-save-file-name (prompt default-name &optional filename)
- (cond
- ((eq filename 'default)
- default-name)
- (filename filename)
- (t
- (let* ((split-name (gnus-get-split-value gnus-split-methods))
- (prompt
- (format prompt (if (and gnus-number-of-articles-to-be-saved
- (> gnus-number-of-articles-to-be-saved 1))
- (format "these %d articles"
- gnus-number-of-articles-to-be-saved)
- "this article")))
- (file
- ;; Let the split methods have their say.
- (cond
- ;; No split name was found.
- ((null split-name)
- (read-file-name
- (concat prompt " (default "
- (file-name-nondirectory default-name) ") ")
- (file-name-directory default-name)
- default-name))
- ;; A single split name was found
- ((= 1 (length split-name))
- (let* ((name (car split-name))
- (dir (cond ((file-directory-p name)
- (file-name-as-directory name))
- ((file-exists-p name) name)
- (t gnus-article-save-directory))))
- (read-file-name
- (concat prompt " (default " name ") ")
- dir name)))
- ;; A list of splits was found.
- (t
- (setq split-name (nreverse split-name))
- (let (result)
- (let ((file-name-history (nconc split-name file-name-history)))
- (setq result
- (expand-file-name
- (read-file-name
- (concat prompt " (`M-p' for defaults) ")
- gnus-article-save-directory
- (car split-name))
- gnus-article-save-directory)))
- (car (push result file-name-history)))))))
- ;; Create the directory.
- (gnus-make-directory (file-name-directory file))
- ;; If we have read a directory, we append the default file name.
- (when (file-directory-p file)
- (setq file (concat (file-name-as-directory file)
- (file-name-nondirectory default-name))))
- ;; Possibly translate some characters.
- (nnheader-translate-file-chars file)))))
+(defun gnus-read-save-file-name (prompt &optional filename
+ function group headers variable)
+ (let ((default-name
+ (funcall function group headers (symbol-value variable)))
+ result)
+ (setq
+ result
+ (cond
+ ((eq filename 'default)
+ default-name)
+ ((eq filename t)
+ default-name)
+ (filename filename)
+ (t
+ (let* ((split-name (gnus-get-split-value gnus-split-methods))
+ (prompt
+ (format prompt
+ (if (and gnus-number-of-articles-to-be-saved
+ (> gnus-number-of-articles-to-be-saved 1))
+ (format "these %d articles"
+ gnus-number-of-articles-to-be-saved)
+ "this article")))
+ (file
+ ;; Let the split methods have their say.
+ (cond
+ ;; No split name was found.
+ ((null split-name)
+ (read-file-name
+ (concat prompt " (default "
+ (file-name-nondirectory default-name) ") ")
+ (file-name-directory default-name)
+ default-name))
+ ;; A single group name is returned.
+ ((stringp split-name)
+ (setq default-name
+ (funcall function split-name headers
+ (symbol-value variable)))
+ (read-file-name
+ (concat prompt " (default "
+ (file-name-nondirectory default-name) ") ")
+ (file-name-directory default-name)
+ default-name))
+ ;; A single split name was found
+ ((= 1 (length split-name))
+ (let* ((name (expand-file-name
+ (car split-name) gnus-article-save-directory))
+ (dir (cond ((file-directory-p name)
+ (file-name-as-directory name))
+ ((file-exists-p name) name)
+ (t gnus-article-save-directory))))
+ (read-file-name
+ (concat prompt " (default " name ") ")
+ dir name)))
+ ;; A list of splits was found.
+ (t
+ (setq split-name (nreverse split-name))
+ (let (result)
+ (let ((file-name-history
+ (nconc split-name file-name-history)))
+ (setq result
+ (expand-file-name
+ (read-file-name
+ (concat prompt " (`M-p' for defaults) ")
+ gnus-article-save-directory
+ (car split-name))
+ gnus-article-save-directory)))
+ (car (push result file-name-history)))))))
+ ;; Create the directory.
+ (gnus-make-directory (file-name-directory file))
+ ;; If we have read a directory, we append the default file name.
+ (when (file-directory-p file)
+ (setq file (concat (file-name-as-directory file)
+ (file-name-nondirectory default-name))))
+ ;; Possibly translate some characters.
+ (nnheader-translate-file-chars file)))))
+ (gnus-make-directory (file-name-directory result))
+ (set variable result)))
(defun gnus-article-archive-name (group)
"Return the first instance of an \"Archive-name\" in the current buffer."
(nnheader-concat gnus-article-save-directory
(match-string 1)))))
+(defun gnus-article-nndoc-name (group)
+ "If GROUP is an nndoc group, return the name of the parent group."
+ (when (eq (car (gnus-find-method-for-group group)) 'nndoc)
+ (gnus-group-get-parameter group 'save-article-group)))
+
(defun gnus-summary-save-in-rmail (&optional filename)
"Append this article to Rmail file.
Optional argument FILENAME specifies file name.
Directory to save to is default to `gnus-article-save-directory'."
(interactive)
(gnus-set-global-variables)
- (let ((default-name
- (funcall gnus-rmail-save-name gnus-newsgroup-name
- gnus-current-headers gnus-newsgroup-last-rmail)))
- (setq filename (gnus-read-save-file-name
- "Save %s in rmail file:" default-name filename))
- (gnus-make-directory (file-name-directory filename))
- (gnus-eval-in-buffer-window gnus-save-article-buffer
- (save-excursion
- (save-restriction
- (widen)
- (gnus-output-to-rmail filename))))
- ;; Remember the directory name to save articles
- (setq gnus-newsgroup-last-rmail filename)))
+ (setq filename (gnus-read-save-file-name
+ "Save %s in rmail file:" filename
+ gnus-rmail-save-name gnus-newsgroup-name
+ gnus-current-headers 'gnus-newsgroup-last-rmail))
+ (gnus-eval-in-buffer-window gnus-save-article-buffer
+ (save-excursion
+ (save-restriction
+ (widen)
+ (gnus-output-to-rmail filename)))))
(defun gnus-summary-save-in-mail (&optional filename)
"Append this article to Unix mail file.
Directory to save to is default to `gnus-article-save-directory'."
(interactive)
(gnus-set-global-variables)
- (let ((default-name
- (funcall gnus-mail-save-name gnus-newsgroup-name
- gnus-current-headers gnus-newsgroup-last-mail)))
- (setq filename (gnus-read-save-file-name
- "Save %s in Unix mail file:" default-name filename))
- (setq filename
- (expand-file-name filename
- (and default-name
- (file-name-directory default-name))))
- (gnus-make-directory (file-name-directory filename))
- (gnus-eval-in-buffer-window gnus-save-article-buffer
- (save-excursion
- (save-restriction
- (widen)
- (if (and (file-readable-p filename) (mail-file-babyl-p filename))
- (gnus-output-to-rmail filename)
- (let ((mail-use-rfc822 t))
- (rmail-output filename 1 t t))))))
- ;; Remember the directory name to save articles.
- (setq gnus-newsgroup-last-mail filename)))
+ (setq filename (gnus-read-save-file-name
+ "Save %s in Unix mail file:" filename
+ gnus-mail-save-name gnus-newsgroup-name
+ gnus-current-headers 'gnus-newsgroup-last-mail))
+ (gnus-eval-in-buffer-window gnus-save-article-buffer
+ (save-excursion
+ (save-restriction
+ (widen)
+ (if (and (file-readable-p filename)
+ (mail-file-babyl-p filename))
+ (gnus-output-to-rmail filename t)
+ (gnus-output-to-mail filename))))))
(defun gnus-summary-save-in-file (&optional filename overwrite)
"Append this article to file.
Directory to save to is default to `gnus-article-save-directory'."
(interactive)
(gnus-set-global-variables)
- (let ((default-name
- (funcall gnus-file-save-name gnus-newsgroup-name
- gnus-current-headers gnus-newsgroup-last-file)))
- (setq filename (gnus-read-save-file-name
- "Save %s in file:" default-name filename))
- (gnus-make-directory (file-name-directory filename))
- (gnus-eval-in-buffer-window gnus-save-article-buffer
- (save-excursion
- (save-restriction
- (widen)
- (when (and overwrite
- (file-exists-p filename))
- (delete-file filename))
- (gnus-output-to-file filename))))
- ;; Remember the directory name to save articles.
- (setq gnus-newsgroup-last-file filename)))
+ (setq filename (gnus-read-save-file-name
+ "Save %s in file:" filename
+ gnus-file-save-name gnus-newsgroup-name
+ gnus-current-headers 'gnus-newsgroup-last-file))
+ (gnus-eval-in-buffer-window gnus-save-article-buffer
+ (save-excursion
+ (save-restriction
+ (widen)
+ (when (and overwrite
+ (file-exists-p filename))
+ (delete-file filename))
+ (gnus-output-to-file filename)))))
(defun gnus-summary-write-to-file (&optional filename)
"Write this article to a file.
The directory to save in defaults to `gnus-article-save-directory'."
(interactive)
(gnus-set-global-variables)
- (let ((default-name
- (funcall gnus-file-save-name gnus-newsgroup-name
- gnus-current-headers gnus-newsgroup-last-file)))
- (setq filename (gnus-read-save-file-name
- "Save %s body in file:" default-name filename))
- (gnus-make-directory (file-name-directory filename))
- (gnus-eval-in-buffer-window gnus-save-article-buffer
- (save-excursion
- (save-restriction
- (widen)
- (goto-char (point-min))
- (when (search-forward "\n\n" nil t)
- (narrow-to-region (point) (point-max)))
- (gnus-output-to-file filename))))
- ;; Remember the directory name to save articles.
- (setq gnus-newsgroup-last-file filename)))
+ (setq filename (gnus-read-save-file-name
+ "Save %s body in file:" filename
+ gnus-file-save-name gnus-newsgroup-name
+ gnus-current-headers 'gnus-newsgroup-last-file))
+ (gnus-eval-in-buffer-window gnus-save-article-buffer
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (when (search-forward "\n\n" nil t)
+ (narrow-to-region (point) (point-max)))
+ (gnus-output-to-file filename)))))
(defun gnus-summary-save-in-pipe (&optional command)
"Pipe this article to subprocess."
(cond ((eq command 'default)
gnus-last-shell-command)
(command command)
- (t (read-string
+ (t (read-string
(format
"Shell command on %s: "
(if (and gnus-number-of-articles-to-be-saved
gfunc (cdr func))
(setq afunc func
gfunc (intern (format "gnus-%s" func))))
- (fset gfunc
+ (fset gfunc
(if (not (fboundp afunc))
nil
`(lambda (&optional interactive &rest args)
article-remove-trailing-blank-lines
article-strip-leading-blank-lines
article-strip-multiple-blank-lines
+ article-strip-leading-space
article-strip-blank-lines
article-date-local
article-date-original
(put 'gnus-article-mode 'mode-class 'special)
-(when t
- (gnus-define-keys gnus-article-mode-map
- " " gnus-article-goto-next-page
- "\177" gnus-article-goto-prev-page
- [delete] gnus-article-goto-prev-page
- "\C-c^" gnus-article-refer-article
- "h" gnus-article-show-summary
- "s" gnus-article-show-summary
- "\C-c\C-m" gnus-article-mail
- "?" gnus-article-describe-briefly
- gnus-mouse-2 gnus-article-push-button
- "\r" gnus-article-press-button
- "\t" gnus-article-next-button
- "\M-\t" gnus-article-prev-button
- "e" gnus-article-edit
- "<" beginning-of-buffer
- ">" end-of-buffer
- "\C-c\C-i" gnus-info-find-node
- "\C-c\C-b" gnus-bug
-
- "\C-d" gnus-article-read-summary-keys
- "\M-*" gnus-article-read-summary-keys
- "\M-g" gnus-article-read-summary-keys)
-
- (substitute-key-definition
- 'undefined 'gnus-article-read-summary-keys gnus-article-mode-map))
+(gnus-define-keys gnus-article-mode-map
+ " " gnus-article-goto-next-page
+ "\177" gnus-article-goto-prev-page
+ [delete] gnus-article-goto-prev-page
+ "\C-c^" gnus-article-refer-article
+ "h" gnus-article-show-summary
+ "s" gnus-article-show-summary
+ "\C-c\C-m" gnus-article-mail
+ "?" gnus-article-describe-briefly
+ gnus-mouse-2 gnus-article-push-button
+ "\r" gnus-article-press-button
+ "\t" gnus-article-next-button
+ "\M-\t" gnus-article-prev-button
+ "e" gnus-article-edit
+ "<" beginning-of-buffer
+ ">" end-of-buffer
+ "\C-c\C-i" gnus-info-find-node
+ "\C-c\C-b" gnus-bug
+
+ "\C-d" gnus-article-read-summary-keys
+ "\M-*" gnus-article-read-summary-keys
+ "\M-#" gnus-article-read-summary-keys
+ "\M-^" gnus-article-read-summary-keys
+ "\M-g" gnus-article-read-summary-keys)
+
+(substitute-key-definition
+ 'undefined 'gnus-article-read-summary-keys gnus-article-mode-map)
(defun gnus-article-make-menu-bar ()
(gnus-turn-off-edit-menu 'article)
["Remove carriage return" gnus-article-remove-cr t]
["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t]))
- (when (boundp 'gnus-summary-article-menu)
- (define-key gnus-article-mode-map [menu-bar commands]
- (cons "Commands" gnus-summary-article-menu)))
+ (when nil
+ (when (boundp 'gnus-summary-article-menu)
+ (define-key gnus-article-mode-map [menu-bar commands]
+ (cons "Commands" gnus-summary-article-menu))))
(when (boundp 'gnus-summary-post-menu)
(define-key gnus-article-mode-map [menu-bar post]
(use-local-map gnus-article-mode-map)
(gnus-update-format-specifications nil 'article-mode)
(set (make-local-variable 'page-delimiter) gnus-page-delimiter)
+ (set (make-local-variable 'gnus-page-broken) nil)
+ (set (make-local-variable 'gnus-button-marker-list) nil)
(gnus-set-default-directory)
(buffer-disable-undo (current-buffer))
(setq buffer-read-only t)
(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)
(run-hooks 'gnus-article-display-hook))
;; Do page break.
(goto-char (point-min))
- (when gnus-break-pages
- (gnus-narrow-to-page)))
+ (setq gnus-page-broken
+ (when gnus-break-pages
+ (gnus-narrow-to-page)
+ t)))
(gnus-set-mode-line 'article)
(gnus-configure-windows 'article)
(goto-char (point-min))
;;; Article savers.
-(defun gnus-output-to-rmail (file-name)
- "Append the current article to an Rmail file named FILE-NAME."
- (require 'rmail)
- ;; Most of these codes are borrowed from rmailout.el.
- (setq file-name (expand-file-name file-name))
- (setq rmail-default-rmail-file file-name)
- (let ((artbuf (current-buffer))
- (tmpbuf (get-buffer-create " *Gnus-output*")))
- (save-excursion
- (or (get-file-buffer file-name)
- (file-exists-p file-name)
- (if (gnus-yes-or-no-p
- (concat "\"" file-name "\" does not exist, create it? "))
- (let ((file-buffer (create-file-buffer file-name)))
- (save-excursion
- (set-buffer file-buffer)
- (rmail-insert-rmail-file-header)
- (let ((require-final-newline nil))
- (gnus-write-buffer file-name)))
- (kill-buffer file-buffer))
- (error "Output file does not exist")))
- (set-buffer tmpbuf)
- (buffer-disable-undo (current-buffer))
- (erase-buffer)
- (insert-buffer-substring artbuf)
- (gnus-convert-article-to-rmail)
- ;; Decide whether to append to a file or to an Emacs buffer.
- (let ((outbuf (get-file-buffer file-name)))
- (if (not outbuf)
- (append-to-file (point-min) (point-max) file-name)
- ;; File has been visited, in buffer OUTBUF.
- (set-buffer outbuf)
- (let ((buffer-read-only nil)
- (msg (and (boundp 'rmail-current-message)
- (symbol-value 'rmail-current-message))))
- ;; If MSG is non-nil, buffer is in RMAIL mode.
- (when msg
- (widen)
- (narrow-to-region (point-max) (point-max)))
- (insert-buffer-substring tmpbuf)
- (when msg
- (goto-char (point-min))
- (widen)
- (search-backward "\^_")
- (narrow-to-region (point) (point-max))
- (goto-char (1+ (point-min)))
- (rmail-count-new-messages t)
- (rmail-show-message msg))))))
- (kill-buffer tmpbuf)))
-
(defun gnus-output-to-file (file-name)
"Append the current article to a file named FILE-NAME."
(let ((artbuf (current-buffer)))
;; save it to file.
(goto-char (point-max))
(insert "\n")
- (append-to-file (point-min) (point-max) file-name))))
-
-(defun gnus-convert-article-to-rmail ()
- "Convert article in current buffer to Rmail message format."
- (let ((buffer-read-only nil))
- ;; Convert article directly into Babyl format.
- ;; Suggested by Rob Austein <sra@lcs.mit.edu>
- (goto-char (point-min))
- (insert "\^L\n0, unseen,,\n*** EOOH ***\n")
- (while (search-forward "\n\^_" nil t) ;single char
- (replace-match "\n^_" t t)) ;2 chars: "^" and "_"
- (goto-char (point-max))
- (insert "\^_")))
+ (append-to-file (point-min) (point-max) file-name)
+ t)))
(defun gnus-narrow-to-page (&optional arg)
"Narrow the article buffer to a page.
"Show the next page of the article."
(interactive)
(when (gnus-article-next-page)
+ (goto-char (point-min))
(gnus-article-read-summary-keys nil (gnus-character-to-event ?n))))
(defun gnus-article-goto-prev-page ()
(and (pos-visible-in-window-p) ;Not continuation line.
(eobp)))
;; Nothing in this page.
- (if (or (not gnus-break-pages)
+ (if (or (not gnus-page-broken)
(save-excursion
(save-restriction
(widen) (forward-line 1) (eobp)))) ;Real end-of-buffer?
projects / gnus / blobdiff