(require 'wid-edit)
(require 'mm-uu)
(require 'message)
+(require 'mouse)
(autoload 'gnus-msg-mail "gnus-msg" nil t)
(autoload 'gnus-button-mailto "gnus-msg")
:type 'regexp
:group 'gnus-article-various)
-(defcustom gnus-article-mode-line-format "Gnus: %g [%w] %S%m"
+(defcustom gnus-article-mode-line-format "Gnus: %g %S%m"
"*The format specification for the article mode line.
See `gnus-summary-mode-line-format' for a closer description.
%w The article washing status.
%m The number of MIME parts in the article."
+ :version "24.1"
:type 'string
:group 'gnus-article-various)
:group 'gnus-article-mime
:type '(repeat (cons :format "%v" (string :tag "MIME type") function)))
-(defcustom gnus-article-date-headers
- (let ((types '(ut local english lapsed combined-lapsed
- iso8601 original user-defined))
- default)
- (dolist (type types)
- (let ((variable (intern (format "gnus-treat-date-%s" type))))
- (when (and (boundp variable)
- (symbol-value variable))
- (push type default))))
- (when (and (or (not (boundp (intern "gnus-article-date-lapsed-new-header")))
- (not (symbol-value (intern "gnus-article-date-lapsed-new-header"))))
- (memq 'lapsed default))
- (setq default (delq 'lapsed default)))
- (or default
- '(combined-lapsed)))
+(defcustom gnus-article-date-headers '(combined-lapsed)
"A list of Date header formats to display.
Valid formats are `ut' (universal time), `local' (local time
zone), `english' (readable English), `lapsed' (elapsed time),
(item :tag "User-defined" :value 'user-defined)))
(defcustom gnus-article-update-date-headers 1
- "How often to update the date header.
+ "A number that says how often to update the date header (in seconds).
If nil, don't update it at all."
:version "24.1"
:group 'gnus-article-headers
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
+(gnus-define-group-parameter
+ list-identifier
+ :variable-document
+ "Alist of regexps and correspondent identifiers."
+ :variable-group gnus-article-washing
+ :parameter-type
+ '(choice :tag "Identifier"
+ :value nil
+ (symbol :tag "Item in `gnus-list-identifiers'" none)
+ regexp
+ (const :tag "None" nil))
+ :parameter-document
+ "If non-nil, specify how to remove `identifiers' from articles' subject.
+
+Any symbol is used to look up a regular expression to match the
+banner in `gnus-list-identifiers'. A string is used as a regular
+expression to match the identifier directly.")
+
(make-obsolete-variable 'gnus-treat-strip-pgp nil
"Gnus 5.10 (Emacs 22.1)")
(put 'gnus-with-article-headers 'edebug-form-spec '(body))
(defmacro gnus-with-article-buffer (&rest forms)
- `(with-current-buffer gnus-article-buffer
- (let ((inhibit-read-only t))
- ,@forms)))
+ `(when (buffer-live-p (get-buffer gnus-article-buffer))
+ (with-current-buffer gnus-article-buffer
+ (let ((inhibit-read-only t))
+ ,@forms))))
(put 'gnus-with-article-buffer 'lisp-indent-function 0)
(put 'gnus-with-article-buffer 'edebug-form-spec '(body))
(let ((start (point)))
(insert "X-Boundary: ")
(gnus-add-text-properties start (point) '(invisible t intangible t))
- (insert (let (str)
- (while (>= (window-width) (length str))
+ (insert (let (str (max (window-width)))
+ (if (featurep 'xemacs)
+ (setq max (1- max)))
+ (while (>= max (length str))
(setq str (concat str gnus-body-boundary-delimiter)))
- (substring str 0 (window-width)))
+ (substring str 0 max))
"\n")
(gnus-put-text-property start (point) 'gnus-decoration 'header)))))
((equal (concat "<" cid ">") (mm-handle-id handle))
(setq file
(expand-file-name
- (or (mail-content-type-get
- (mm-handle-disposition handle) 'filename)
- (mail-content-type-get
- (setq type (mm-handle-type handle)) 'name)
- (concat
- (make-temp-name "cid")
- (car (rassoc (car type) mailcap-mime-extensions))))
- directory))
+ (or (mm-handle-filename handle)
+ (concat
+ (make-temp-name "cid")
+ (car (rassoc (car (mm-handle-type handle)) mailcap-mime-extensions))))
+ directory))
(mm-save-part-to-file handle file)
(throw 'found file))))))))
((or (equal (car (setq type (mm-handle-type handle))) "text/html")
(and (equal (car type) "message/external-body")
(or header
- (setq file (or (mail-content-type-get type 'name)
- (mail-content-type-get
- (mm-handle-disposition handle)
- 'filename))))
+ (setq file (mm-handle-filename handle)))
(or (mm-handle-cache handle)
(condition-case code
(progn (mm-extern-cache-contents handle) t)
The `gnus-list-identifiers' variable specifies what to do."
(interactive)
(let ((inhibit-point-motion-hooks t)
- (regexp (if (consp gnus-list-identifiers)
- (mapconcat 'identity gnus-list-identifiers " *\\|")
- gnus-list-identifiers))
- (inhibit-read-only t))
+ (regexp (gnus-group-get-list-identifiers gnus-newsgroup-name))
+ (inhibit-read-only t))
(when regexp
(save-excursion
(save-restriction
(setq ended t)))))
(defun article-treat-date ()
- (article-date-ut gnus-article-date-headers t))
+ (article-date-ut (if (gnus-buffer-live-p gnus-summary-buffer)
+ (with-current-buffer gnus-summary-buffer
+ gnus-article-date-headers)
+ gnus-article-date-headers)
+ t))
(defun article-date-ut (&optional type highlight date-position)
"Convert DATE date to TYPE in the current article.
(inhibit-read-only t)
(inhibit-point-motion-hooks t)
(first t)
+ (visible-date (mail-fetch-field "Date"))
pos date bface eface)
(save-excursion
(save-restriction
- (widen)
(goto-char (point-min))
- (while (or (setq date (get-text-property (setq pos (point))
- 'original-date))
- (when (setq pos (next-single-property-change
- (point) 'original-date))
- (setq date (get-text-property pos 'original-date))
- t))
- (narrow-to-region
- pos (if (setq pos (text-property-any pos (point-max)
- 'original-date nil))
- (progn
- (goto-char pos)
- (if (or (bolp) (eobp))
- (point)
- (1+ (point))))
- (point-max)))
- (goto-char (point-min))
- (when (re-search-forward "^Date:" nil t)
- (setq bface (get-text-property (point-at-bol) 'face)
- eface (get-text-property (1- (point-at-eol)) 'face)))
- (goto-char (point-min))
- ;; Delete any old Date headers.
- (if date-position
- (progn
- (goto-char date-position)
- (delete-region (point)
- (progn
- (gnus-article-forward-header)
- (point))))
- (while (re-search-forward "^Date:" nil t)
- (delete-region (point-at-bol) (progn
- (gnus-article-forward-header)
- (point)))))
- (dolist (this-type (cond
- ((null type)
- (list 'ut))
- ((atom type)
- (list type))
- (t
- type)))
- (insert (article-make-date-line date (or this-type 'ut)) "\n")
- (forward-line -1)
- (put-text-property (line-beginning-position)
- (1+ (line-beginning-position))
- 'gnus-date-type this-type)
- ;; Do highlighting.
- (beginning-of-line)
- (when (looking-at "\\([^:]+\\): *\\(.*\\)$")
- (put-text-property (match-beginning 1) (1+ (match-end 1))
- 'face bface)
- (put-text-property (match-beginning 2) (match-end 2)
- 'face eface)))
- (put-text-property (point-min) (1- (point-max)) 'original-date date)
- (goto-char (point-max))
- (widen))))))
+ (when (re-search-forward "^Date:" nil t)
+ (setq bface (get-text-property (point-at-bol) 'face)
+ eface (get-text-property (1- (point-at-eol)) 'face)))
+ (goto-char (point-min))
+ ;; Delete any old Date headers.
+ (if date-position
+ (progn
+ (goto-char date-position)
+ (setq date (get-text-property (point) 'original-date))
+ (delete-region (point)
+ (progn
+ (gnus-article-forward-header)
+ (point)))
+ (article-transform-date date type bface eface))
+ (while (re-search-forward "^Date:" nil t)
+ (setq date (get-text-property (match-beginning 0) 'original-date))
+ (delete-region (point-at-bol) (progn
+ (gnus-article-forward-header)
+ (point))))
+ (when (and (not date)
+ visible-date)
+ (setq date visible-date))
+ (when date
+ (article-transform-date date type bface eface)))))))
+
+(defun article-transform-date (date type bface eface)
+ (dolist (this-type (cond
+ ((null type)
+ (list 'ut))
+ ((atom type)
+ (list type))
+ (t
+ type)))
+ (insert (article-make-date-line date (or this-type 'ut)) "\n")
+ (forward-line -1)
+ (beginning-of-line)
+ (put-text-property (point) (1+ (point))
+ 'original-date date)
+ (put-text-property (point) (1+ (point))
+ 'gnus-date-type this-type)
+ ;; Do highlighting.
+ (when (looking-at "\\([^:]+\\): *\\(.*\\)$")
+ (put-text-property (match-beginning 1) (1+ (match-end 1))
+ 'face bface)
+ (put-text-property (match-beginning 2) (match-end 2)
+ 'face eface))
+ (forward-line 1)))
(defun article-make-date-line (date type)
"Return a DATE line of TYPE."
combined-lapsed))
(error "Unknown conversion type: %s" type))
(condition-case ()
- (let ((time (date-to-time date)))
+ (let ((time (ignore-errors (date-to-time date))))
(cond
;; Convert to the local timezone.
((eq type 'local)
(segments 3)
lapsed-string)
(while (and
+ time
(setq lapsed-string
(concat " (" (article-lapsed-string time segments) ")"))
(> (+ (length date-string)
(defun article-update-date-lapsed ()
"Function to be run from a timer to update the lapsed time line."
(save-match-data
- (let (deactivate-mark)
- (save-window-excursion
- (ignore-errors
- (walk-windows
- (lambda (w)
- (set-buffer (window-buffer w))
- (when (eq major-mode 'gnus-article-mode)
- (let ((old-line (count-lines (point-min) (point)))
- (old-column (current-column)))
- (goto-char (point-min))
- (while (re-search-forward "^Date:" nil t)
- (let ((type (get-text-property (match-beginning 0) 'gnus-date-type)))
- (when (memq type '(lapsed combined-lapsed user-format))
- (save-excursion
- (article-date-ut type t (match-beginning 0)))
- (forward-line 1))))
- (goto-char (point-min))
- (when (> old-column 0)
- (setq old-line (1- old-line)))
- (forward-line old-line)
- (end-of-line)
- (when (> (current-column) old-column)
- (beginning-of-line)
- (forward-char old-column)))))
- nil 'visible))))))
+ (let ((buffer (current-buffer)))
+ (ignore-errors
+ (walk-windows
+ (lambda (w)
+ (set-buffer (window-buffer w))
+ (when (eq major-mode 'gnus-article-mode)
+ (let ((old-line (count-lines (point-min) (point)))
+ (old-column (- (point) (line-beginning-position)))
+ (window-start
+ (window-start (get-buffer-window (current-buffer)))))
+ (goto-char (point-min))
+ (while (re-search-forward "^Date:" nil t)
+ (let ((type (get-text-property (match-beginning 0)
+ 'gnus-date-type)))
+ (when (memq type '(lapsed combined-lapsed user-format))
+ (when (and window-start
+ (not (= window-start
+ (save-excursion
+ (forward-line 1)
+ (point)))))
+ (setq window-start nil))
+ (save-excursion
+ (article-date-ut type t (match-beginning 0)))
+ (forward-line 1)
+ (when window-start
+ (set-window-start (get-buffer-window (current-buffer))
+ (point))))))
+ (goto-char (point-min))
+ (when (> old-column 0)
+ (setq old-line (1- old-line)))
+ (forward-line old-line)
+ (end-of-line)
+ (when (> (current-column) old-column)
+ (beginning-of-line)
+ (forward-char old-column)))))
+ nil 'visible))
+ (set-buffer buffer))))
(defun gnus-start-date-timer (&optional n)
"Start a timer to update the Date headers in the article buffers.
(setq gnus-summary-buffer
(gnus-summary-buffer-name gnus-newsgroup-name))
(gnus-summary-set-local-parameters gnus-newsgroup-name)
- (when (and gnus-article-update-date-headers
- (not article-lapsed-timer))
+ (when article-lapsed-timer
+ (gnus-stop-date-timer))
+ (when gnus-article-update-date-headers
(gnus-start-date-timer gnus-article-update-date-headers))
(current-buffer)))))
(forward-line -1))
(set-window-point (get-buffer-window (current-buffer)) (point))
(gnus-configure-windows 'article)
+ (gnus-run-hooks 'gnus-article-prepare-hook)
t))))))
;;;###autoload
gnus-article-image-alist nil)
(gnus-run-hooks 'gnus-tmp-internal-hook)
(when gnus-display-mime-function
- (funcall gnus-display-mime-function))
- (gnus-run-hooks 'gnus-article-prepare-hook)))
+ (funcall gnus-display-mime-function))))
;;;
;;; Gnus Sticky Article Mode
(when (zerop parts)
(error "No such part"))
(pop-to-buffer gnus-article-buffer)
- ;; FIXME: why is it necessary?
- (sit-for 0)
(or n
(setq n (if (= parts 1)
1
(let* ((data (get-text-property (point) 'gnus-data))
(id (get-text-property (point) 'gnus-part))
(handles gnus-article-mime-handles)
- (none "(none)")
(description
(let ((desc (mm-handle-description data)))
(when desc
(mail-decode-encoded-word-string desc))))
- (filename
- (or (mail-content-type-get (mm-handle-disposition data) 'filename)
- none))
+ (filename (or (mm-handle-filename (mm-handle-disposition data)) "(none)"))
(type (mm-handle-media-type data)))
(unless data
(error "No MIME part under point"))
(unless handle
(setq handle (get-text-property (point) 'gnus-data)))
(when handle
- (let ((filename (or (mail-content-type-get (mm-handle-type handle)
- 'name)
- (mail-content-type-get (mm-handle-disposition handle)
- 'filename)))
+ (let ((filename (mm-handle-filename handle))
contents dont-decode charset coding-system)
(mm-with-unibyte-buffer
(mm-insert-part handle)
(mm-with-unibyte-buffer
(mm-insert-part handle)
(setq contents
- (or (mm-decompress-buffer
- (or (mail-content-type-get (mm-handle-type handle)
- 'name)
- (mail-content-type-get (mm-handle-disposition handle)
- 'filename))
- nil t)
+ (or (mm-decompress-buffer (mm-handle-filename handle) nil t)
(buffer-string))))
(cond
((not arg)
(defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed)
(let ((gnus-tmp-name
- (or (mail-content-type-get (mm-handle-type handle) 'name)
- (mail-content-type-get (mm-handle-disposition handle) 'filename)
+ (or (mm-handle-filename handle)
(mail-content-type-get (mm-handle-type handle) 'url)
""))
(gnus-tmp-type (mm-handle-media-type handle))
(defun gnus-article-next-page-1 (lines)
(condition-case ()
- (let ((scroll-in-place nil))
+ (let ((scroll-in-place nil)
+ (auto-window-vscroll nil))
(scroll-up lines))
(end-of-buffer
;; Long lines may cause an end-of-buffer error.
(defvar gnus-button-handle-describe-prefix "^\\(C-h\\|<?[Ff]1>?\\)")
-;; FIXME: Maybe we should merge some of the functions that do quite similar
-;; stuff?
-
(defun gnus-button-handle-describe-function (url)
"Call `describe-function' when pushing the corresponding URL button."
(describe-function
projects / gnus / blobdiff