(defvar gnus-article-mode-hook nil
"*A hook for Gnus article mode.")
+(defvar gnus-article-menu-hook nil
+ "*Hook run after the creation of the article mode menu.")
+
(defvar gnus-article-prepare-hook nil
"*A hook called after an article has been prepared in the article buffer.
If you want to run a special decoding program like nkf, use this hook.")
(nconc '((?w (gnus-article-wash-status) ?s))
gnus-summary-mode-line-format-alist))
+(defvar gnus-number-of-articles-to-be-saved nil)
+
;;; Provide a mapping from `gnus-*' commands to Article commands.
(eval-and-compile
article-treat-overstrike
(article-fill . gnus-article-word-wrap)
article-remove-cr
- article-remove-trailing-blank-lines
article-display-x-face
article-de-quoted-unreadable
article-mime-decode-quoted-printable
article-hide-pgp
article-hide-pem
article-hide-signature
+ article-remove-trailing-blank-lines
article-strip-leading-blank-lines
+ article-strip-multiple-blank-lines
+ article-strip-blank-lines
article-date-local
article-date-original
article-date-lapsed
;;; Saving functions.
-(defun gnus-article-save (save-buffer file)
+(defun gnus-article-save (save-buffer file &optional num)
"Save the currently selected article."
(unless gnus-save-all-headers
;; Remove headers accoring to `gnus-saved-headers'.
;; `gnus-original-article-buffer' (or so they think),
;; but we bind that variable to our save-buffer.
(set-buffer gnus-article-buffer)
- (let ((gnus-original-article-buffer save-buffer))
+ (let* ((gnus-original-article-buffer save-buffer)
+ (filename
+ (cond
+ ((not gnus-prompt-before-saving)
+ 'default)
+ ((eq gnus-prompt-before-saving 'always)
+ nil)
+ (t file)))
+ (gnus-number-of-articles-to-be-saved
+ (when (stringp filename) num))) ; Magic
(set-buffer gnus-summary-buffer)
- (funcall
- gnus-default-article-saver
- (cond
- ((not gnus-prompt-before-saving)
- 'default)
- ((eq gnus-prompt-before-saving 'always)
- nil)
- (t file)))))))
-
-(defun gnus-read-save-file-name (prompt default-name)
- (let* ((split-name (gnus-get-split-value gnus-split-methods))
- (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
- (read-file-name
- (concat prompt " (`M-p' for defaults) ")
- gnus-article-save-directory
- (car split-name))))
- (car (push result file-name-history)))))))
- ;; Create the directory.
- (unless (equal (directory-file-name file) file)
- (make-directory (file-name-directory file) t))
- ;; 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)))
+ (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
+ (read-file-name
+ (concat prompt " (`M-p' for defaults) ")
+ gnus-article-save-directory
+ (car split-name))))
+ (car (push result file-name-history)))))))
+ ;; Create the directory.
+ (unless (equal (directory-file-name file) file)
+ (make-directory (file-name-directory file) t))
+ ;; 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-article-archive-name (group)
"Return the first instance of an \"Archive-name\" in the current buffer."
(let ((default-name
(funcall gnus-rmail-save-name gnus-newsgroup-name
gnus-current-headers gnus-newsgroup-last-rmail)))
- (setq filename
- (cond ((eq filename 'default)
- default-name)
- (filename filename)
- (t (gnus-read-save-file-name
- "Save in rmail file:" default-name))))
- (make-directory (file-name-directory filename) t)
+ (setq filename (gnus-read-save-file-name
+ "Save %s in rmail file:" default-name filename))
+ (unless (file-exists-p (file-name-directory filename))
+ (make-directory (file-name-directory filename) t))
(gnus-eval-in-buffer-window gnus-original-article-buffer
(save-excursion
(save-restriction
(let ((default-name
(funcall gnus-mail-save-name gnus-newsgroup-name
gnus-current-headers gnus-newsgroup-last-mail)))
- (setq filename
- (cond ((eq filename 'default)
- default-name)
- (filename filename)
- (t (gnus-read-save-file-name
- "Save in Unix mail file:" default-name))))
+ (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))))
- (make-directory (file-name-directory filename) t)
+ (unless (file-exists-p (file-name-directory filename))
+ (make-directory (file-name-directory filename) t))
(gnus-eval-in-buffer-window gnus-original-article-buffer
(save-excursion
(save-restriction
(let ((default-name
(funcall gnus-file-save-name gnus-newsgroup-name
gnus-current-headers gnus-newsgroup-last-file)))
- (setq filename
- (cond ((eq filename 'default)
- default-name)
- (filename filename)
- (t (gnus-read-save-file-name
- "Save in file:" default-name))))
- (make-directory (file-name-directory filename) t)
+ (setq filename (gnus-read-save-file-name
+ "Save %s in file:" default-name filename))
+ (unless (file-exists-p (file-name-directory filename))
+ (make-directory (file-name-directory filename) t))
(gnus-eval-in-buffer-window gnus-original-article-buffer
(save-excursion
(save-restriction
(let ((default-name
(funcall gnus-file-save-name gnus-newsgroup-name
gnus-current-headers gnus-newsgroup-last-file)))
- (setq filename
- (cond ((eq filename 'default)
- default-name)
- (filename filename)
- (t (gnus-read-save-file-name
- "Save body in file:" default-name))))
- (make-directory (file-name-directory filename) t)
+ (setq filename (gnus-read-save-file-name
+ "Save %s body in file:" default-name filename))
+ (unless (file-exists-p (file-name-directory filename))
+ (make-directory (file-name-directory filename) t))
(gnus-eval-in-buffer-window gnus-original-article-buffer
(save-excursion
(save-restriction
"\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
(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)
+ (unless (boundp 'gnus-article-article-menu)
+ (easy-menu-define
+ gnus-article-article-menu gnus-article-mode-map ""
+ '("Article"
+ ["Scroll forwards" gnus-article-goto-next-page t]
+ ["Scroll backwards" gnus-article-goto-prev-page t]
+ ["Show summary" gnus-article-show-summary t]
+ ["Fetch Message-ID at point" gnus-article-refer-article t]
+ ["Mail to address at point" gnus-article-mail t]
+ ))
+
+ (easy-menu-define
+ gnus-article-treatment-menu gnus-article-mode-map ""
+ '("Treatment"
+ ["Hide headers" gnus-article-hide-headers t]
+ ["Hide signature" gnus-article-hide-signature t]
+ ["Hide citation" gnus-article-hide-citation t]
+ ["Treat overstrike" gnus-article-treat-overstrike t]
+ ["Remove carriage return" gnus-article-remove-cr t]
+ ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t]
+ ))
+ (run-hooks 'gnus-article-menu-hook)))
+
(defun gnus-article-mode ()
"Major mode for displaying an article.
All normal editing commands are switched off.
-The following commands are available:
-
+The following commands are available in addition to all summary mode
+commands:
\\<gnus-article-mode-map>
\\[gnus-article-next-page]\t Scroll the article one page forwards
\\[gnus-article-prev-page]\t Scroll the article one page backwards
(cons (list 'gnus-show-mime " MIME") minor-mode-alist)))
(use-local-map gnus-article-mode-map)
(gnus-update-format-specifications nil 'article-mode)
- (make-local-variable 'page-delimiter)
- (setq page-delimiter gnus-page-delimiter)
+ (set (make-local-variable 'page-delimiter) gnus-page-delimiter)
+ (gnus-set-default-directory)
(buffer-disable-undo (current-buffer))
(setq buffer-read-only t) ;Disable modification
(run-hooks 'gnus-article-mode-hook))
(set-buffer gnus-article-buffer)
(goto-char (point-min))
(widen)
+ ;; Remove any old next/prev buttons.
(when (gnus-visual-p 'page-marker)
(let ((buffer-read-only nil))
(gnus-remove-text-with-property 'gnus-prev)
(goto-char (point-min))
(gnus-insert-prev-page-button)))
(when (and (gnus-visual-p 'page-marker)
- (not (= (1- (point-max)) (buffer-size))))
+ (< (+ (point-max) 2) (buffer-size)))
(save-excursion
(goto-char (point-max))
(gnus-insert-next-page-button)))))
(defvar gnus-article-edit-mode-hook nil
"*Hook run in article edit mode buffers.")
+(defvar gnus-article-edit-done-function nil)
+
(defvar gnus-article-edit-mode-map nil)
(unless gnus-article-edit-mode-map
(setq gnus-article-edit-mode-map (copy-keymap text-mode-map))
(gnus-define-keys gnus-article-edit-mode-map
- "\C-c\C-c" 'gnus-summary-edit-article-done)
+ "\C-c\C-c" gnus-article-edit-done
+ "\C-c\C-k" gnus-article-edit-exit)
(gnus-define-keys (gnus-article-edit-wash-map
"\C-c\C-w" gnus-article-edit-mode-map)
(kill-all-local-variables)
(setq major-mode 'gnus-article-edit-mode)
(setq mode-name "Article Edit")
- (make-local-variable 'minor-mode-alist)
(use-local-map gnus-article-edit-mode-map)
+ (make-local-variable 'gnus-article-edit-done-function)
+ (make-local-variable 'gnus-prev-winconf)
+ (setq buffer-read-only nil)
+ (buffer-enable-undo)
+ (widen)
(run-hooks 'text-mode 'gnus-article-edit-mode-hook))
+(defun gnus-article-edit (&optional force)
+ "Edit the current article.
+This will have permanent effect only in mail groups.
+If FORCE is non-nil, allow editing of articles even in read-only
+groups."
+ (interactive "P")
+ (when (and (not force)
+ (gnus-group-read-only-p))
+ (error "The current newsgroup does not support article editing."))
+ (gnus-article-edit-article
+ `(lambda ()
+ (gnus-summary-edit-article-done
+ ,(or (mail-header-references gnus-current-headers) "")
+ ,(gnus-group-read-only-p) ,gnus-summary-buffer))))
+
+(defun gnus-article-edit-article (exit-func)
+ "Start editing the contents of the current article buffer."
+ (let ((winconf (current-window-configuration)))
+ (set-buffer gnus-article-buffer)
+ (gnus-article-edit-mode)
+ (set-text-properties (point-min) (point-max) nil)
+ (gnus-configure-windows 'edit-article)
+ (setq gnus-article-edit-done-function exit-func)
+ (setq gnus-prev-winconf winconf)
+ (gnus-message 6 "C-c C-c to end edits")))
+
+(defun gnus-article-edit-done ()
+ "Update the article edits and exit."
+ (interactive)
+ (let ((func gnus-article-edit-done-function)
+ (buf (current-buffer))
+ (start (window-start)))
+ (gnus-article-edit-exit)
+ (let ((cur (current-buffer)))
+ (save-excursion
+ (set-buffer buf)
+ (let ((buffer-read-only nil))
+ (funcall func)))
+ (set-buffer buf)
+ (set-window-start (get-buffer-window buf) start)
+ (set-window-point (get-buffer-window buf) (point)))))
+
+(defun gnus-article-edit-exit ()
+ "Exit the article editing without updating."
+ (interactive)
+ ;; We remove all text props from the article buffer.
+ (let ((buf (format "%s" (buffer-string)))
+ (curbuf (current-buffer))
+ (p (point))
+ (window-start (window-start)))
+ (erase-buffer)
+ (insert buf)
+ (let ((winconf gnus-prev-winconf))
+ (gnus-article-mode)
+ ;; The cache and backlog have to be flushed somewhat.
+ (when gnus-use-cache
+ (gnus-cache-update-article
+ (car gnus-article-current) (cdr gnus-article-current)))
+ (when gnus-keep-backlog
+ (gnus-backlog-remove-article
+ (car gnus-article-current) (cdr gnus-article-current)))
+ ;; Flush original article as well.
+ (save-excursion
+ (when (get-buffer gnus-original-article-buffer)
+ (set-buffer gnus-original-article-buffer)
+ (setq gnus-original-article nil)))
+ (set-window-configuration winconf)
+ ;; Tippy-toe some to make sure that point remains where it was.
+ (let ((buf (current-buffer)))
+ (set-buffer curbuf)
+ (set-window-start (get-buffer-window (current-buffer)) window-start)
+ (goto-char p)
+ (set-buffer buf)))))
+
(defun gnus-article-edit-full-stops ()
"Interactively repair spacing at end of sentences."
(interactive)
(let ((case-fold-search nil))
(query-replace-regexp "\\([.!?][])}]* \\)\\([[({A-Z]\\)" "\\1 \\2"))))
+;;;
+;;; Article highlights
+;;;
+
+;; Written by Per Abrahamsen <abraham@iesd.auc.dk>.
+
+;;; Internal Variables:
+
+(defvar gnus-button-url-regexp "\\b\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?[-\\wa-zA-Z0-9_=!?#$@~`%&*+|\\/.,]*[-\\wa-zA-Z0-9_=#$@~`%&*+|\\/]"
+ "*Regular expression that matches URLs.")
+
+(defvar gnus-button-alist
+ `(("\\bin\\( +article\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2
+ t gnus-button-message-id 3)
+ ("\\(<?\\(url: ?\\)?news:\\([^>\n\t ]*\\)>?\\)" 1 t
+ gnus-button-message-id 3)
+ ("\\(<URL: *\\)?mailto: *\\([^> \n\t]+\\)>?" 0 t gnus-button-reply 2)
+ ;; This is how URLs _should_ be embedded in text...
+ ("<URL: *\\([^\n\r>]*\\)>" 0 t gnus-button-url 1)
+ ;; Next regexp stolen from highlight-headers.el.
+ ;; Modified by Vladimir Alexiev.
+ (,gnus-button-url-regexp 0 t gnus-button-url 0))
+ "Alist of regexps matching buttons in article bodies.
+
+Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where
+REGEXP: is the string matching text around the button,
+BUTTON: is the number of the regexp grouping actually matching the button,
+FORM: is a lisp expression which must eval to true for the button to
+be added,
+CALLBACK: is the function to call when the user push this button, and each
+PAR: is a number of a regexp grouping whose text will be passed to CALLBACK.
+
+CALLBACK can also be a variable, in that case the value of that
+variable it the real callback function.")
+
+(defvar gnus-header-button-alist
+ `(("^\\(References\\|Message-I[Dd]\\):" "<[^>]+>"
+ 0 t gnus-button-message-id 0)
+ ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 t gnus-button-reply 1)
+ ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+"
+ 0 t gnus-button-mailto 0)
+ ("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t gnus-button-url 0)
+ ("^[^:]+:" ,gnus-button-url-regexp 0 t gnus-button-url 0)
+ ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t
+ gnus-button-message-id 3))
+ "Alist of headers and regexps to match buttons in article heads.
+
+This alist is very similar to `gnus-button-alist', except that each
+alist has an additional HEADER element first in each entry:
+
+\(HEADER REGEXP BUTTON FORM CALLBACK PAR)
+
+HEADER is a regexp to match a header. For a fuller explanation, see
+`gnus-button-alist'.")
+
+(defvar gnus-button-regexp nil)
+(defvar gnus-button-marker-list nil)
+;; Regexp matching any of the regexps from `gnus-button-alist'.
+
+(defvar gnus-button-last nil)
+;; The value of `gnus-button-alist' when `gnus-button-regexp' was build.
+
+;;; Commands:
+
+(defun gnus-article-push-button (event)
+ "Check text under the mouse pointer for a callback function.
+If the text under the mouse pointer has a `gnus-callback' property,
+call it with the value of the `gnus-data' text property."
+ (interactive "e")
+ (set-buffer (window-buffer (posn-window (event-start event))))
+ (let* ((pos (posn-point (event-start event)))
+ (data (get-text-property pos 'gnus-data))
+ (fun (get-text-property pos 'gnus-callback)))
+ (if fun (funcall fun data))))
+
+(defun gnus-article-press-button ()
+ "Check text at point for a callback function.
+If the text at point has a `gnus-callback' property,
+call it with the value of the `gnus-data' text property."
+ (interactive)
+ (let* ((data (get-text-property (point) 'gnus-data))
+ (fun (get-text-property (point) 'gnus-callback)))
+ (if fun (funcall fun data))))
+
+(defun gnus-article-prev-button (n)
+ "Move point to N buttons backward.
+If N is negative, move forward instead."
+ (interactive "p")
+ (gnus-article-next-button (- n)))
+
+(defun gnus-article-next-button (n)
+ "Move point to N buttons forward.
+If N is negative, move backward instead."
+ (interactive "p")
+ (let ((function (if (< n 0) 'previous-single-property-change
+ 'next-single-property-change))
+ (inhibit-point-motion-hooks t)
+ (backward (< n 0))
+ (limit (if (< n 0) (point-min) (point-max))))
+ (setq n (abs n))
+ (while (and (not (= limit (point)))
+ (> n 0))
+ ;; Skip past the current button.
+ (when (get-text-property (point) 'gnus-callback)
+ (goto-char (funcall function (point) 'gnus-callback nil limit)))
+ ;; Go to the next (or previous) button.
+ (gnus-goto-char (funcall function (point) 'gnus-callback nil limit))
+ ;; Put point at the start of the button.
+ (when (and backward (not (get-text-property (point) 'gnus-callback)))
+ (goto-char (funcall function (point) 'gnus-callback nil limit)))
+ ;; Skip past intangible buttons.
+ (when (get-text-property (point) 'intangible)
+ (incf n))
+ (decf n))
+ (unless (zerop n)
+ (gnus-message 5 "No more buttons"))
+ n))
+
+(defun gnus-article-highlight (&optional force)
+ "Highlight current article.
+This function calls `gnus-article-highlight-headers',
+`gnus-article-highlight-citation',
+`gnus-article-highlight-signature', and `gnus-article-add-buttons' to
+do the highlighting. See the documentation for those functions."
+ (interactive (list 'force))
+ (gnus-article-highlight-headers)
+ (gnus-article-highlight-citation force)
+ (gnus-article-highlight-signature)
+ (gnus-article-add-buttons force)
+ (gnus-article-add-buttons-to-head))
+
+(defun gnus-article-highlight-some (&optional force)
+ "Highlight current article.
+This function calls `gnus-article-highlight-headers',
+`gnus-article-highlight-signature', and `gnus-article-add-buttons' to
+do the highlighting. See the documentation for those functions."
+ (interactive (list 'force))
+ (gnus-article-highlight-headers)
+ (gnus-article-highlight-signature)
+ (gnus-article-add-buttons))
+
+(defun gnus-article-highlight-headers ()
+ "Highlight article headers as specified by `gnus-header-face-alist'."
+ (interactive)
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (save-restriction
+ (let ((alist gnus-header-face-alist)
+ (buffer-read-only nil)
+ (case-fold-search t)
+ (inhibit-point-motion-hooks t)
+ entry regexp header-face field-face from hpoints fpoints)
+ (goto-char (point-min))
+ (when (search-forward "\n\n" nil t)
+ (narrow-to-region (1- (point)) (point-min))
+ (while (setq entry (pop alist))
+ (goto-char (point-min))
+ (setq regexp (concat "^\\("
+ (if (string-equal "" (nth 0 entry))
+ "[^\t ]"
+ (nth 0 entry))
+ "\\)")
+ header-face (nth 1 entry)
+ field-face (nth 2 entry))
+ (while (and (re-search-forward regexp nil t)
+ (not (eobp)))
+ (beginning-of-line)
+ (setq from (point))
+ (or (search-forward ":" nil t)
+ (forward-char 1))
+ (when (and header-face
+ (not (memq (point) hpoints)))
+ (push (point) hpoints)
+ (gnus-put-text-property from (point) 'face header-face))
+ (when (and field-face
+ (not (memq (setq from (point)) fpoints)))
+ (push from fpoints)
+ (if (re-search-forward "^[^ \t]" nil t)
+ (forward-char -2)
+ (goto-char (point-max)))
+ (gnus-put-text-property from (point) 'face field-face)))))))))
+
+(defun gnus-article-highlight-signature ()
+ "Highlight the signature in an article.
+It does this by highlighting everything after
+`gnus-signature-separator' using `gnus-signature-face'."
+ (interactive)
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (let ((buffer-read-only nil)
+ (inhibit-point-motion-hooks t))
+ (save-restriction
+ (when (and gnus-signature-face
+ (article-narrow-to-signature))
+ (gnus-overlay-put (gnus-make-overlay (point-min) (point-max))
+ 'face gnus-signature-face)
+ (widen)
+ (article-search-signature)
+ (let ((start (match-beginning 0))
+ (end (set-marker (make-marker) (1+ (match-end 0)))))
+ (gnus-article-add-button start (1- end) 'gnus-signature-toggle
+ end)))))))
+
+(defun gnus-article-add-buttons (&optional force)
+ "Find external references in the article and make buttons of them.
+\"External references\" are things like Message-IDs and URLs, as
+specified by `gnus-button-alist'."
+ (interactive (list 'force))
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ ;; Remove all old markers.
+ (while gnus-button-marker-list
+ (set-marker (pop gnus-button-marker-list) nil))
+ (let ((buffer-read-only nil)
+ (inhibit-point-motion-hooks t)
+ (case-fold-search t)
+ (alist gnus-button-alist)
+ beg entry regexp)
+ (goto-char (point-min))
+ ;; We skip the headers.
+ (unless (search-forward "\n\n" nil t)
+ (goto-char (point-max)))
+ (setq beg (point))
+ (while (setq entry (pop alist))
+ (setq regexp (car entry))
+ (goto-char beg)
+ (while (re-search-forward regexp nil t)
+ (let* ((start (and entry (match-beginning (nth 1 entry))))
+ (end (and entry (match-end (nth 1 entry))))
+ (from (match-beginning 0)))
+ (when (or (eq t (nth 1 entry))
+ (eval (nth 1 entry)))
+ ;; That optional form returned non-nil, so we add the
+ ;; button.
+ (gnus-article-add-button
+ start end 'gnus-button-push
+ (car (push (set-marker (make-marker) from)
+ gnus-button-marker-list))))))))))
+
+;; Add buttons to the head of an article.
+(defun gnus-article-add-buttons-to-head ()
+ "Add buttons to the head of the article."
+ (interactive)
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (let ((buffer-read-only nil)
+ (inhibit-point-motion-hooks t)
+ (case-fold-search t)
+ (alist gnus-header-button-alist)
+ entry beg end)
+ (nnheader-narrow-to-headers)
+ (while alist
+ ;; Each alist entry.
+ (setq entry (car alist)
+ alist (cdr alist))
+ (goto-char (point-min))
+ (while (re-search-forward (car entry) nil t)
+ ;; Each header matching the entry.
+ (setq beg (match-beginning 0))
+ (setq end (or (and (re-search-forward "^[^ \t]" nil t)
+ (match-beginning 0))
+ (point-max)))
+ (goto-char beg)
+ (while (re-search-forward (nth 1 entry) end t)
+ ;; Each match within a header.
+ (let* ((from (match-beginning 0))
+ (entry (cdr entry))
+ (start (match-beginning (nth 1 entry)))
+ (end (match-end (nth 1 entry)))
+ (form (nth 2 entry)))
+ (goto-char (match-end 0))
+ (and (eval form)
+ (gnus-article-add-button
+ start end (nth 3 entry)
+ (buffer-substring (match-beginning (nth 4 entry))
+ (match-end (nth 4 entry)))))))
+ (goto-char end))))
+ (widen)))
+
+;;; External functions:
+
+(defun gnus-article-add-button (from to fun &optional data)
+ "Create a button between FROM and TO with callback FUN and data DATA."
+ (and gnus-article-button-face
+ (gnus-overlay-put (gnus-make-overlay from to)
+ 'face gnus-article-button-face))
+ (gnus-add-text-properties
+ from to
+ (nconc (and gnus-article-mouse-face
+ (list gnus-mouse-face-prop gnus-article-mouse-face))
+ (list 'gnus-callback fun)
+ (and data (list 'gnus-data data)))))
+
+;;; Internal functions:
+
+(defun gnus-signature-toggle (end)
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (let ((buffer-read-only nil)
+ (inhibit-point-motion-hooks t))
+ (if (get-text-property end 'invisible)
+ (article-unhide-text end (point-max))
+ (article-hide-text end (point-max) gnus-hidden-properties)))))
+
+(defun gnus-button-entry ()
+ ;; Return the first entry in `gnus-button-alist' matching this place.
+ (let ((alist gnus-button-alist)
+ (entry nil))
+ (while alist
+ (setq entry (pop alist))
+ (if (looking-at (car entry))
+ (setq alist nil)
+ (setq entry nil)))
+ entry))
+
+(defun gnus-button-push (marker)
+ ;; Push button starting at MARKER.
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (goto-char marker)
+ (let* ((entry (gnus-button-entry))
+ (inhibit-point-motion-hooks t)
+ (fun (nth 3 entry))
+ (args (mapcar (lambda (group)
+ (let ((string (buffer-substring
+ (match-beginning group)
+ (match-end group))))
+ (gnus-set-text-properties
+ 0 (length string) nil string)
+ string))
+ (nthcdr 4 entry))))
+ (cond
+ ((fboundp fun)
+ (apply fun args))
+ ((and (boundp fun)
+ (fboundp (symbol-value fun)))
+ (apply (symbol-value fun) args))
+ (t
+ (gnus-message 1 "You must define `%S' to use this button"
+ (cons fun args)))))))
+
+(defun gnus-button-message-id (message-id)
+ "Fetch MESSAGE-ID."
+ (save-excursion
+ (set-buffer gnus-summary-buffer)
+ (gnus-summary-refer-article message-id)))
+
+(defun gnus-button-mailto (address)
+ ;; Mail to ADDRESS.
+ (set-buffer (gnus-copy-article-buffer))
+ (message-reply address))
+
+(defun gnus-button-reply (address)
+ ;; Reply to ADDRESS.
+ (message-reply address))
+
+(defun gnus-button-url (address)
+ "Browse ADDRESS."
+ (funcall browse-url-browser-function address))
+
+;;; Next/prev buttons in the article buffer.
+
+(defvar gnus-next-page-line-format "%{%(Next page...%)%}\n")
+(defvar gnus-prev-page-line-format "%{%(Previous page...%)%}\n")
+
+(defvar gnus-prev-page-map nil)
+(unless gnus-prev-page-map
+ (setq gnus-prev-page-map (make-sparse-keymap))
+ (define-key gnus-prev-page-map gnus-mouse-2 'gnus-button-prev-page)
+ (define-key gnus-prev-page-map "\r" 'gnus-button-prev-page))
+
+(defun gnus-insert-prev-page-button ()
+ (let ((buffer-read-only nil))
+ (gnus-eval-format
+ gnus-prev-page-line-format nil
+ `(gnus-prev t local-map ,gnus-prev-page-map
+ gnus-callback gnus-article-button-prev-page))))
+
+(defvar gnus-next-page-map nil)
+(unless gnus-next-page-map
+ (setq gnus-next-page-map (make-keymap))
+ (suppress-keymap gnus-prev-page-map)
+ (define-key gnus-next-page-map gnus-mouse-2 'gnus-button-next-page)
+ (define-key gnus-next-page-map "\r" 'gnus-button-next-page))
+
+(defun gnus-button-next-page ()
+ "Go to the next page."
+ (interactive)
+ (let ((win (selected-window)))
+ (select-window (get-buffer-window gnus-article-buffer t))
+ (gnus-article-next-page)
+ (select-window win)))
+
+(defun gnus-button-prev-page ()
+ "Go to the prev page."
+ (interactive)
+ (let ((win (selected-window)))
+ (select-window (get-buffer-window gnus-article-buffer t))
+ (gnus-article-prev-page)
+ (select-window win)))
+
+(defun gnus-insert-next-page-button ()
+ (let ((buffer-read-only nil))
+ (gnus-eval-format gnus-next-page-line-format nil
+ `(gnus-next t local-map ,gnus-next-page-map
+ gnus-callback
+ gnus-article-button-next-page))))
+
+(defun gnus-article-button-next-page (arg)
+ "Go to the next page."
+ (interactive "P")
+ (let ((win (selected-window)))
+ (select-window (get-buffer-window gnus-article-buffer t))
+ (gnus-article-next-page)
+ (select-window win)))
+
+(defun gnus-article-button-prev-page (arg)
+ "Go to the prev page."
+ (interactive "P")
+ (let ((win (selected-window)))
+ (select-window (get-buffer-window gnus-article-buffer t))
+ (gnus-article-prev-page)
+ (select-window win)))
+
(provide 'gnus-art)
;;; gnus-art.el ends here
projects / gnus / blobdiff