-(defun gnus-summary-jump-to-group (newsgroup)
- "Move point to NEWSGROUP in group mode buffer."
- ;; Keep update point of group mode buffer if visible.
- (if (eq (current-buffer) (get-buffer gnus-group-buffer))
- (save-window-excursion
- ;; Take care of tree window mode.
- (if (get-buffer-window gnus-group-buffer)
- (pop-to-buffer gnus-group-buffer))
- (gnus-group-jump-to-group newsgroup))
- (save-excursion
- ;; Take care of tree window mode.
- (if (get-buffer-window gnus-group-buffer)
- (pop-to-buffer gnus-group-buffer)
- (set-buffer gnus-group-buffer))
- (gnus-group-jump-to-group newsgroup))))
-
-;; This function returns a list of article numbers based on the
-;; difference between the ranges of read articles in this group and
-;; the range of active articles.
-(defun gnus-list-of-unread-articles (group)
- (let* ((read (gnus-info-read (gnus-get-info group)))
- (active (gnus-active group))
- (last (cdr active))
- first nlast unread)
- ;; If none are read, then all are unread.
- (if (not read)
- (setq first (car active))
- ;; If the range of read articles is a single range, then the
- ;; first unread article is the article after the last read
- ;; article. Sounds logical, doesn't it?
- (if (not (listp (cdr read)))
- (setq first (1+ (cdr read)))
- ;; `read' is a list of ranges.
- (if (/= (setq nlast (or (and (numberp (car read)) (car read))
- (caar read))) 1)
- (setq first 1))
- (while read
- (if first
- (while (< first nlast)
- (setq unread (cons first unread))
- (setq first (1+ first))))
- (setq first (1+ (if (atom (car read)) (car read) (cdar read))))
- (setq nlast (if (atom (cadr read)) (cadr read) (caadr read)))
- (setq read (cdr read)))))
- ;; And add the last unread articles.
- (while (<= first last)
- (setq unread (cons first unread))
- (setq first (1+ first)))
- ;; Return the list of unread articles.
- (nreverse unread)))
-
-(defun gnus-list-of-read-articles (group)
- "Return a list of unread, unticked and non-dormant articles."
- (let* ((info (gnus-get-info group))
- (marked (gnus-info-marks info))
- (active (gnus-active group)))
- (and info active
- (gnus-set-difference
- (gnus-sorted-complement
- (gnus-uncompress-range active)
- (gnus-list-of-unread-articles group))
- (append
- (gnus-uncompress-range (cdr (assq 'dormant marked)))
- (gnus-uncompress-range (cdr (assq 'tick marked))))))))
-
-;; Various summary commands
-
-(defun gnus-summary-universal-argument (arg)
- "Perform any operation on all articles that are process/prefixed."
- (interactive "P")
- (gnus-set-global-variables)
- (let ((articles (gnus-summary-work-articles arg))
- func article)
- (if (eq
- (setq
- func
- (key-binding
- (read-key-sequence
- (substitute-command-keys
- "\\<gnus-summary-mode-map>\\[gnus-summary-universal-argument]"
- ))))
- 'undefined)
- (gnus-error 1 "Undefined key")
- (save-excursion
- (while articles
- (gnus-summary-goto-subject (setq article (pop articles)))
- (command-execute func)
- (gnus-summary-remove-process-mark article)))))
- (gnus-summary-position-point))
-
-(defun gnus-summary-toggle-truncation (&optional arg)
- "Toggle truncation of summary lines.
-With arg, turn line truncation on iff arg is positive."
- (interactive "P")
- (setq truncate-lines
- (if (null arg) (not truncate-lines)
- (> (prefix-numeric-value arg) 0)))
- (redraw-display))
-
-(defun gnus-summary-reselect-current-group (&optional all rescan)
- "Exit and then reselect the current newsgroup.
-The prefix argument ALL means to select all articles."
- (interactive "P")
- (gnus-set-global-variables)
- (when (gnus-ephemeral-group-p gnus-newsgroup-name)
- (error "Ephemeral groups can't be reselected"))
- (let ((current-subject (gnus-summary-article-number))
- (group gnus-newsgroup-name))
- (setq gnus-newsgroup-begin nil)
- (gnus-summary-exit)
- ;; We have to adjust the point of group mode buffer because the
- ;; current point was moved to the next unread newsgroup by
- ;; exiting.
- (gnus-summary-jump-to-group group)
- (when rescan
- (save-excursion
- (gnus-group-get-new-news-this-group 1)))
- (gnus-group-read-group all t)
- (gnus-summary-goto-subject current-subject nil t)))
-
-(defun gnus-summary-rescan-group (&optional all)
- "Exit the newsgroup, ask for new articles, and select the newsgroup."
- (interactive "P")
- (gnus-summary-reselect-current-group all t))
-
-(defun gnus-summary-update-info ()
- (let* ((group gnus-newsgroup-name))
- (when gnus-newsgroup-kill-headers
- (setq gnus-newsgroup-killed
- (gnus-compress-sequence
- (nconc
- (gnus-set-sorted-intersection
- (gnus-uncompress-range gnus-newsgroup-killed)
- (setq gnus-newsgroup-unselected
- (sort gnus-newsgroup-unselected '<)))
- (setq gnus-newsgroup-unreads
- (sort gnus-newsgroup-unreads '<))) t)))
- (unless (listp (cdr gnus-newsgroup-killed))
- (setq gnus-newsgroup-killed (list gnus-newsgroup-killed)))
- (let ((headers gnus-newsgroup-headers))
- (run-hooks 'gnus-exit-group-hook)
- (unless gnus-save-score
- (setq gnus-newsgroup-scored nil))
- ;; Set the new ranges of read articles.
- (gnus-update-read-articles
- group (append gnus-newsgroup-unreads gnus-newsgroup-unselected))
- ;; Set the current article marks.
- (gnus-update-marks)
- ;; Do the cross-ref thing.
- (when gnus-use-cross-reference
- (gnus-mark-xrefs-as-read group headers gnus-newsgroup-unreads))
- ;; Do adaptive scoring, and possibly save score files.
- (when gnus-newsgroup-adaptive
- (gnus-score-adaptive))
- (when gnus-use-scoring
- (gnus-score-save))
- ;; Do not switch windows but change the buffer to work.
- (set-buffer gnus-group-buffer)
- (or (gnus-ephemeral-group-p gnus-newsgroup-name)
- (gnus-group-update-group group)))))
-
-(defun gnus-summary-exit (&optional temporary)
- "Exit reading current newsgroup, and then return to group selection mode.
-gnus-exit-group-hook is called with no arguments if that value is non-nil."
- (interactive)
- (gnus-set-global-variables)
- (gnus-kill-save-kill-buffer)
- (let* ((group gnus-newsgroup-name)
- (quit-config (gnus-group-quit-config gnus-newsgroup-name))
- (mode major-mode)
- (buf (current-buffer)))
- (run-hooks 'gnus-summary-prepare-exit-hook)
- ;; If we have several article buffers, we kill them at exit.
- (unless gnus-single-article-buffer
- (gnus-kill-buffer gnus-original-article-buffer)
- (setq gnus-article-current nil))
- (when gnus-use-cache
- (gnus-cache-possibly-remove-articles)
- (gnus-cache-save-buffers))
- (when gnus-use-trees
- (gnus-tree-close group))
- ;; Make all changes in this group permanent.
- (unless quit-config
- (gnus-summary-update-info))
- (gnus-close-group group)
- ;; Make sure where I was, and go to next newsgroup.
- (set-buffer gnus-group-buffer)
- (unless quit-config
- (gnus-group-jump-to-group group))
- (run-hooks 'gnus-summary-exit-hook)
- (unless quit-config
- (gnus-group-next-unread-group 1))
- (if temporary
- nil ;Nothing to do.
- ;; If we have several article buffers, we kill them at exit.
- (unless gnus-single-article-buffer
- (gnus-kill-buffer gnus-article-buffer)
- (gnus-kill-buffer gnus-original-article-buffer)
- (setq gnus-article-current nil))
- (set-buffer buf)
- (if (not gnus-kill-summary-on-exit)
- (gnus-deaden-summary)
- ;; We set all buffer-local variables to nil. It is unclear why
- ;; this is needed, but if we don't, buffer-local variables are
- ;; not garbage-collected, it seems. This would the lead to en
- ;; ever-growing Emacs.
- (gnus-summary-clear-local-variables)
- (when (get-buffer gnus-article-buffer)
- (bury-buffer gnus-article-buffer))
- ;; We clear the global counterparts of the buffer-local
- ;; variables as well, just to be on the safe side.
- (gnus-configure-windows 'group 'force)
- (gnus-summary-clear-local-variables)
- ;; Return to group mode buffer.
- (if (eq mode 'gnus-summary-mode)
- (gnus-kill-buffer buf)))
- (setq gnus-current-select-method gnus-select-method)
- (pop-to-buffer gnus-group-buffer)
- ;; Clear the current group name.
- (if (not quit-config)
- (progn
- (gnus-group-jump-to-group group)
- (gnus-group-next-unread-group 1)
- (gnus-configure-windows 'group 'force))
- (if (not (buffer-name (car quit-config)))
- (gnus-configure-windows 'group 'force)
- (set-buffer (car quit-config))
- (and (eq major-mode 'gnus-summary-mode)
- (gnus-set-global-variables))
- (gnus-configure-windows (cdr quit-config))))
- (unless quit-config
- (setq gnus-newsgroup-name nil)))))
-
-(defalias 'gnus-summary-quit 'gnus-summary-exit-no-update)
-(defun gnus-summary-exit-no-update (&optional no-questions)
- "Quit reading current newsgroup without updating read article info."
- (interactive)
- (gnus-set-global-variables)
- (let* ((group gnus-newsgroup-name)
- (quit-config (gnus-group-quit-config group)))
- (when (or no-questions
- gnus-expert-user
- (gnus-y-or-n-p "Do you really wanna quit reading this group? "))
- ;; If we have several article buffers, we kill them at exit.
- (unless gnus-single-article-buffer
- (gnus-kill-buffer gnus-article-buffer)
- (gnus-kill-buffer gnus-original-article-buffer)
- (setq gnus-article-current nil))
- (if (not gnus-kill-summary-on-exit)
- (gnus-deaden-summary)
- (gnus-close-group group)
- (gnus-summary-clear-local-variables)
- (set-buffer gnus-group-buffer)
- (gnus-summary-clear-local-variables)
- (when (get-buffer gnus-summary-buffer)
- (kill-buffer gnus-summary-buffer)))
- (unless gnus-single-article-buffer
- (setq gnus-article-current nil))
- (when gnus-use-trees
- (gnus-tree-close group))
- (when (get-buffer gnus-article-buffer)
- (bury-buffer gnus-article-buffer))
- ;; Return to the group buffer.
- (gnus-configure-windows 'group 'force)
- ;; Clear the current group name.
- (setq gnus-newsgroup-name nil)
- (when (equal (gnus-group-group-name) group)
- (gnus-group-next-unread-group 1))
- (when quit-config
- (if (not (buffer-name (car quit-config)))
- (gnus-configure-windows 'group 'force)
- (set-buffer (car quit-config))
- (when (eq major-mode 'gnus-summary-mode)
- (gnus-set-global-variables))
- (gnus-configure-windows (cdr quit-config)))))))
-
-;;; Dead summaries.
-
-(defvar gnus-dead-summary-mode-map nil)
-
-(if gnus-dead-summary-mode-map
- nil
- (setq gnus-dead-summary-mode-map (make-keymap))
- (suppress-keymap gnus-dead-summary-mode-map)
- (substitute-key-definition
- 'undefined 'gnus-summary-wake-up-the-dead gnus-dead-summary-mode-map)
- (let ((keys '("\C-d" "\r" "\177")))
- (while keys
- (define-key gnus-dead-summary-mode-map
- (pop keys) 'gnus-summary-wake-up-the-dead))))
-
-(defvar gnus-dead-summary-mode nil
- "Minor mode for Gnus summary buffers.")
-
-(defun gnus-dead-summary-mode (&optional arg)
- "Minor mode for Gnus summary buffers."
- (interactive "P")
- (when (eq major-mode 'gnus-summary-mode)
- (make-local-variable 'gnus-dead-summary-mode)
- (setq gnus-dead-summary-mode
- (if (null arg) (not gnus-dead-summary-mode)
- (> (prefix-numeric-value arg) 0)))
- (when gnus-dead-summary-mode
- (unless (assq 'gnus-dead-summary-mode minor-mode-alist)
- (push '(gnus-dead-summary-mode " Dead") minor-mode-alist))
- (unless (assq 'gnus-dead-summary-mode minor-mode-map-alist)
- (push (cons 'gnus-dead-summary-mode gnus-dead-summary-mode-map)
- minor-mode-map-alist)))))
-
-(defun gnus-deaden-summary ()
- "Make the current summary buffer into a dead summary buffer."
- ;; Kill any previous dead summary buffer.
- (when (and gnus-dead-summary
- (buffer-name gnus-dead-summary))
- (save-excursion
- (set-buffer gnus-dead-summary)
- (when gnus-dead-summary-mode
- (kill-buffer (current-buffer)))))
- ;; Make this the current dead summary.
- (setq gnus-dead-summary (current-buffer))
- (gnus-dead-summary-mode 1)
- (let ((name (buffer-name)))
- (when (string-match "Summary" name)
- (rename-buffer
- (concat (substring name 0 (match-beginning 0)) "Dead "
- (substring name (match-beginning 0))) t))))
-
-(defun gnus-kill-or-deaden-summary (buffer)
- "Kill or deaden the summary BUFFER."
- (when (and (buffer-name buffer)
- (not gnus-single-article-buffer))
- (save-excursion
- (set-buffer buffer)
- (gnus-kill-buffer gnus-article-buffer)
- (gnus-kill-buffer gnus-original-article-buffer)))
- (cond (gnus-kill-summary-on-exit
- (when (and gnus-use-trees
- (and (get-buffer buffer)
- (buffer-name (get-buffer buffer))))
- (save-excursion
- (set-buffer (get-buffer buffer))
- (gnus-tree-close gnus-newsgroup-name)))
- (gnus-kill-buffer buffer))
- ((and (get-buffer buffer)
- (buffer-name (get-buffer buffer)))
- (save-excursion
- (set-buffer buffer)
- (gnus-deaden-summary)))))
-
-(defun gnus-summary-wake-up-the-dead (&rest args)
- "Wake up the dead summary buffer."
- (interactive)
- (gnus-dead-summary-mode -1)
- (let ((name (buffer-name)))
- (when (string-match "Dead " name)
- (rename-buffer
- (concat (substring name 0 (match-beginning 0))
- (substring name (match-end 0))) t)))
- (gnus-message 3 "This dead summary is now alive again"))
-
-;; Suggested by Andrew Eskilsson <pi92ae@pt.hk-r.se>.
-(defun gnus-summary-fetch-faq (&optional faq-dir)
- "Fetch the FAQ for the current group.
-If FAQ-DIR (the prefix), prompt for a directory to search for the faq
-in."
- (interactive
- (list
- (if current-prefix-arg
- (completing-read
- "Faq dir: " (and (listp gnus-group-faq-directory)
- gnus-group-faq-directory)))))
- (let (gnus-faq-buffer)
- (and (setq gnus-faq-buffer
- (gnus-group-fetch-faq gnus-newsgroup-name faq-dir))
- (gnus-configure-windows 'summary-faq))))
-
-;; Suggested by Per Abrahamsen <amanda@iesd.auc.dk>.
-(defun gnus-summary-describe-group (&optional force)
- "Describe the current newsgroup."
- (interactive "P")
- (gnus-group-describe-group force gnus-newsgroup-name))
-
-(defun gnus-summary-describe-briefly ()
- "Describe summary mode commands briefly."
- (interactive)
- (gnus-message 6
- (substitute-command-keys "\\<gnus-summary-mode-map>\\[gnus-summary-next-page]:Select \\[gnus-summary-next-unread-article]:Forward \\[gnus-summary-prev-unread-article]:Backward \\[gnus-summary-exit]:Exit \\[gnus-info-find-node]:Run Info \\[gnus-summary-describe-briefly]:This help")))
-
-;; Walking around group mode buffer from summary mode.
-
-(defun gnus-summary-next-group (&optional no-article target-group backward)
- "Exit current newsgroup and then select next unread newsgroup.
-If prefix argument NO-ARTICLE is non-nil, no article is selected
-initially. If NEXT-GROUP, go to this group. If BACKWARD, go to
-previous group instead."
- (interactive "P")
- (gnus-set-global-variables)
- (let ((current-group gnus-newsgroup-name)
- (current-buffer (current-buffer))
- entered)
- ;; First we semi-exit this group to update Xrefs and all variables.
- ;; We can't do a real exit, because the window conf must remain
- ;; the same in case the user is prompted for info, and we don't
- ;; want the window conf to change before that...
- (gnus-summary-exit t)
- (while (not entered)
- ;; Then we find what group we are supposed to enter.
- (set-buffer gnus-group-buffer)
- (gnus-group-jump-to-group current-group)
- (setq target-group
- (or target-group
- (if (eq gnus-keep-same-level 'best)
- (gnus-summary-best-group gnus-newsgroup-name)
- (gnus-summary-search-group backward gnus-keep-same-level))))
- (if (not target-group)
- ;; There are no further groups, so we return to the group
- ;; buffer.
- (progn
- (gnus-message 5 "Returning to the group buffer")
- (setq entered t)
- (set-buffer current-buffer)
- (gnus-summary-exit))
- ;; We try to enter the target group.
- (gnus-group-jump-to-group target-group)
- (let ((unreads (gnus-group-group-unread)))
- (if (and (or (eq t unreads)
- (and unreads (not (zerop unreads))))
- (gnus-summary-read-group
- target-group nil no-article current-buffer))
- (setq entered t)
- (setq current-group target-group
- target-group nil)))))))
-
-(defun gnus-summary-prev-group (&optional no-article)
- "Exit current newsgroup and then select previous unread newsgroup.
-If prefix argument NO-ARTICLE is non-nil, no article is selected initially."
- (interactive "P")
- (gnus-summary-next-group no-article nil t))
-
-;; Walking around summary lines.
-
-(defun gnus-summary-first-subject (&optional unread)
- "Go to the first unread subject.
-If UNREAD is non-nil, go to the first unread article.
-Returns the article selected or nil if there are no unread articles."
- (interactive "P")
- (prog1
- (cond
- ;; Empty summary.
- ((null gnus-newsgroup-data)
- (gnus-message 3 "No articles in the group")
- nil)
- ;; Pick the first article.
- ((not unread)
- (goto-char (gnus-data-pos (car gnus-newsgroup-data)))
- (gnus-data-number (car gnus-newsgroup-data)))
- ;; No unread articles.
- ((null gnus-newsgroup-unreads)
- (gnus-message 3 "No more unread articles")
- nil)
- ;; Find the first unread article.
- (t
- (let ((data gnus-newsgroup-data))
- (while (and data
- (not (gnus-data-unread-p (car data))))
- (setq data (cdr data)))
- (if data
- (progn
- (goto-char (gnus-data-pos (car data)))
- (gnus-data-number (car data)))))))
- (gnus-summary-position-point)))
-
-(defun gnus-summary-next-subject (n &optional unread dont-display)
- "Go to next N'th summary line.
-If N is negative, go to the previous N'th subject line.
-If UNREAD is non-nil, only unread articles are selected.
-The difference between N and the actual number of steps taken is
-returned."
- (interactive "p")
- (let ((backward (< n 0))
- (n (abs n)))
- (while (and (> n 0)
- (if backward
- (gnus-summary-find-prev unread)
- (gnus-summary-find-next unread)))
- (setq n (1- n)))
- (if (/= 0 n) (gnus-message 7 "No more%s articles"
- (if unread " unread" "")))
- (unless dont-display
- (gnus-summary-recenter)
- (gnus-summary-position-point))
- n))
-
-(defun gnus-summary-next-unread-subject (n)
- "Go to next N'th unread summary line."
- (interactive "p")
- (gnus-summary-next-subject n t))
-
-(defun gnus-summary-prev-subject (n &optional unread)
- "Go to previous N'th summary line.
-If optional argument UNREAD is non-nil, only unread article is selected."
- (interactive "p")
- (gnus-summary-next-subject (- n) unread))
-
-(defun gnus-summary-prev-unread-subject (n)
- "Go to previous N'th unread summary line."
- (interactive "p")
- (gnus-summary-next-subject (- n) t))
-
-(defun gnus-summary-goto-subject (article &optional force silent)
- "Go the subject line of ARTICLE.
-If FORCE, also allow jumping to articles not currently shown."
- (let ((b (point))
- (data (gnus-data-find article)))
- ;; We read in the article if we have to.
- (and (not data)
- force
- (gnus-summary-insert-subject article (and (vectorp force) force) t)
- (setq data (gnus-data-find article)))
- (goto-char b)
- (if (not data)
- (progn
- (unless silent
- (gnus-message 3 "Can't find article %d" article))
- nil)
- (goto-char (gnus-data-pos data))
- article)))
-
-;; Walking around summary lines with displaying articles.
-
-(defun gnus-summary-expand-window (&optional arg)
- "Make the summary buffer take up the entire Emacs frame.
-Given a prefix, will force an `article' buffer configuration."
- (interactive "P")
- (gnus-set-global-variables)
- (if arg
- (gnus-configure-windows 'article 'force)
- (gnus-configure-windows 'summary 'force)))
-
-(defun gnus-summary-display-article (article &optional all-header)
- "Display ARTICLE in article buffer."
- (gnus-set-global-variables)
- (if (null article)
- nil
- (prog1
- (if gnus-summary-display-article-function
- (funcall gnus-summary-display-article-function article all-header)
- (gnus-article-prepare article all-header))
- (run-hooks 'gnus-select-article-hook)
- (unless (zerop gnus-current-article)
- (gnus-summary-goto-subject gnus-current-article))
- (gnus-summary-recenter)
- (when gnus-use-trees
- (gnus-possibly-generate-tree article)
- (gnus-highlight-selected-tree article))
- ;; Successfully display article.
- (gnus-article-set-window-start
- (cdr (assq article gnus-newsgroup-bookmarks))))))
-
-(defun gnus-summary-select-article (&optional all-headers force pseudo article)
- "Select the current article.
-If ALL-HEADERS is non-nil, show all header fields. If FORCE is
-non-nil, the article will be re-fetched even if it already present in
-the article buffer. If PSEUDO is non-nil, pseudo-articles will also
-be displayed."
- ;; Make sure we are in the summary buffer to work around bbdb bug.
- (unless (eq major-mode 'gnus-summary-mode)
- (set-buffer gnus-summary-buffer))
- (let ((article (or article (gnus-summary-article-number)))
- (all-headers (not (not all-headers))) ;Must be T or NIL.
- gnus-summary-display-article-function
- did)
- (and (not pseudo)
- (gnus-summary-article-pseudo-p article)
- (error "This is a pseudo-article."))
- (prog1
- (save-excursion
- (set-buffer gnus-summary-buffer)
- (if (or (and gnus-single-article-buffer
- (or (null gnus-current-article)
- (null gnus-article-current)
- (null (get-buffer gnus-article-buffer))
- (not (eq article (cdr gnus-article-current)))
- (not (equal (car gnus-article-current)
- gnus-newsgroup-name))))
- (and (not gnus-single-article-buffer)
- (or (null gnus-current-article)
- (not (eq gnus-current-article article))))
- force)
- ;; The requested article is different from the current article.
- (prog1
- (gnus-summary-display-article article all-headers)
- (setq did article))
- (if (or all-headers gnus-show-all-headers)
- (gnus-article-show-all-headers))
- 'old))
- (if did
- (gnus-article-set-window-start
- (cdr (assq article gnus-newsgroup-bookmarks)))))))
-
-(defun gnus-summary-set-current-mark (&optional current-mark)
- "Obsolete function."
- nil)
-
-(defun gnus-summary-next-article (&optional unread subject backward push)
- "Select the next article.
-If UNREAD, only unread articles are selected.
-If SUBJECT, only articles with SUBJECT are selected.
-If BACKWARD, the previous article is selected instead of the next."
- (interactive "P")
- (gnus-set-global-variables)
- (cond
- ;; Is there such an article?
- ((and (gnus-summary-search-forward unread subject backward)
- (or (gnus-summary-display-article (gnus-summary-article-number))
- (eq (gnus-summary-article-mark) gnus-canceled-mark)))
- (gnus-summary-position-point))
- ;; If not, we try the first unread, if that is wanted.
- ((and subject
- gnus-auto-select-same
- (gnus-summary-first-unread-article))
- (gnus-summary-position-point)
- (gnus-message 6 "Wrapped"))
- ;; Try to get next/previous article not displayed in this group.
- ((and gnus-auto-extend-newsgroup
- (not unread) (not subject))
- (gnus-summary-goto-article
- (if backward (1- gnus-newsgroup-begin) (1+ gnus-newsgroup-end))
- nil t))
- ;; Go to next/previous group.
- (t
- (or (gnus-ephemeral-group-p gnus-newsgroup-name)
- (gnus-summary-jump-to-group gnus-newsgroup-name))
- (let ((cmd last-command-char)
- (group
- (if (eq gnus-keep-same-level 'best)
- (gnus-summary-best-group gnus-newsgroup-name)
- (gnus-summary-search-group backward gnus-keep-same-level))))
- ;; For some reason, the group window gets selected. We change
- ;; it back.
- (select-window (get-buffer-window (current-buffer)))
- ;; Select next unread newsgroup automagically.
- (cond
- ((or (not gnus-auto-select-next)
- (not cmd))
- (gnus-message 7 "No more%s articles" (if unread " unread" "")))
- ((or (eq gnus-auto-select-next 'quietly)
- (and (eq gnus-auto-select-next 'slightly-quietly)
- push)
- (and (eq gnus-auto-select-next 'almost-quietly)
- (gnus-summary-last-article-p)))
- ;; Select quietly.
- (if (gnus-ephemeral-group-p gnus-newsgroup-name)
- (gnus-summary-exit)
- (gnus-message 7 "No more%s articles (%s)..."
- (if unread " unread" "")
- (if group (concat "selecting " group)
- "exiting"))
- (gnus-summary-next-group nil group backward)))
- (t
- (gnus-summary-walk-group-buffer
- gnus-newsgroup-name cmd unread backward)))))))
-
-(defun gnus-summary-walk-group-buffer (from-group cmd unread backward)
- (let ((keystrokes '((?\C-n (gnus-group-next-unread-group 1))
- (?\C-p (gnus-group-prev-unread-group 1))))
- keve key group ended)
- (save-excursion
- (set-buffer gnus-group-buffer)
- (gnus-summary-jump-to-group from-group)
- (setq group
- (if (eq gnus-keep-same-level 'best)
- (gnus-summary-best-group gnus-newsgroup-name)
- (gnus-summary-search-group backward gnus-keep-same-level))))
- (while (not ended)
- (gnus-message
- 5 "No more%s articles%s" (if unread " unread" "")
- (if (and group
- (not (gnus-ephemeral-group-p gnus-newsgroup-name)))
- (format " (Type %s for %s [%s])"
- (single-key-description cmd) group
- (car (gnus-gethash group gnus-newsrc-hashtb)))
- (format " (Type %s to exit %s)"
- (single-key-description cmd)
- gnus-newsgroup-name)))
- ;; Confirm auto selection.
- (setq key (car (setq keve (gnus-read-event-char))))
- (setq ended t)
- (cond
- ((assq key keystrokes)
- (let ((obuf (current-buffer)))
- (switch-to-buffer gnus-group-buffer)
- (and group
- (gnus-group-jump-to-group group))
- (eval (cadr (assq key keystrokes)))
- (setq group (gnus-group-group-name))
- (switch-to-buffer obuf))
- (setq ended nil))
- ((equal key cmd)
- (if (or (not group)
- (gnus-ephemeral-group-p gnus-newsgroup-name))
- (gnus-summary-exit)
- (gnus-summary-next-group nil group backward)))
- (t
- (push (cdr keve) unread-command-events))))))
-
-(defun gnus-read-event-char ()
- "Get the next event."
- (let ((event (read-event)))
- (cons (and (numberp event) event) event)))
-
-(defun gnus-summary-next-unread-article ()
- "Select unread article after current one."
- (interactive)
- (gnus-summary-next-article t (and gnus-auto-select-same
- (gnus-summary-article-subject))))
-
-(defun gnus-summary-prev-article (&optional unread subject)
- "Select the article after the current one.
-If UNREAD is non-nil, only unread articles are selected."
- (interactive "P")
- (gnus-summary-next-article unread subject t))
-
-(defun gnus-summary-prev-unread-article ()
- "Select unred article before current one."
- (interactive)
- (gnus-summary-prev-article t (and gnus-auto-select-same
- (gnus-summary-article-subject))))
-
-(defun gnus-summary-next-page (&optional lines circular)
- "Show next page of the selected article.
-If at the end of the current article, select the next article.
-LINES says how many lines should be scrolled up.
-
-If CIRCULAR is non-nil, go to the start of the article instead of
-selecting the next article when reaching the end of the current
-article."
- (interactive "P")
- (setq gnus-summary-buffer (current-buffer))
- (gnus-set-global-variables)
- (let ((article (gnus-summary-article-number))
- (endp nil))
- (gnus-configure-windows 'article)
- (if (eq (cdr (assq article gnus-newsgroup-reads)) gnus-canceled-mark)
- (if (and (eq gnus-summary-goto-unread 'never)
- (not (gnus-summary-last-article-p article)))
- (gnus-summary-next-article)
- (gnus-summary-next-unread-article))
- (if (or (null gnus-current-article)
- (null gnus-article-current)
- (/= article (cdr gnus-article-current))
- (not (equal (car gnus-article-current) gnus-newsgroup-name)))
- ;; Selected subject is different from current article's.
- (gnus-summary-display-article article)
- (gnus-eval-in-buffer-window gnus-article-buffer
- (setq endp (gnus-article-next-page lines)))
- (if endp
- (cond (circular
- (gnus-summary-beginning-of-article))
- (lines
- (gnus-message 3 "End of message"))
- ((null lines)
- (if (and (eq gnus-summary-goto-unread 'never)
- (not (gnus-summary-last-article-p article)))
- (gnus-summary-next-article)
- (gnus-summary-next-unread-article)))))))
- (gnus-summary-recenter)
- (gnus-summary-position-point)))
-
-(defun gnus-summary-prev-page (&optional lines)
- "Show previous page of selected article.
-Argument LINES specifies lines to be scrolled down."
- (interactive "P")
- (gnus-set-global-variables)
- (let ((article (gnus-summary-article-number)))
- (gnus-configure-windows 'article)
- (if (or (null gnus-current-article)
- (null gnus-article-current)
- (/= article (cdr gnus-article-current))
- (not (equal (car gnus-article-current) gnus-newsgroup-name)))
- ;; Selected subject is different from current article's.
- (gnus-summary-display-article article)
- (gnus-summary-recenter)
- (gnus-eval-in-buffer-window gnus-article-buffer
- (gnus-article-prev-page lines))))
- (gnus-summary-position-point))
-
-(defun gnus-summary-scroll-up (lines)
- "Scroll up (or down) one line current article.
-Argument LINES specifies lines to be scrolled up (or down if negative)."
- (interactive "p")
- (gnus-set-global-variables)
- (gnus-configure-windows 'article)
- (gnus-summary-show-thread)
- (when (eq (gnus-summary-select-article nil nil 'pseudo) 'old)
- (gnus-eval-in-buffer-window gnus-article-buffer
- (cond ((> lines 0)
- (if (gnus-article-next-page lines)
- (gnus-message 3 "End of message")))
- ((< lines 0)
- (gnus-article-prev-page (- lines))))))
- (gnus-summary-recenter)
- (gnus-summary-position-point))
-
-(defun gnus-summary-next-same-subject ()
- "Select next article which has the same subject as current one."
- (interactive)
- (gnus-set-global-variables)
- (gnus-summary-next-article nil (gnus-summary-article-subject)))
-
-(defun gnus-summary-prev-same-subject ()
- "Select previous article which has the same subject as current one."
- (interactive)
- (gnus-set-global-variables)
- (gnus-summary-prev-article nil (gnus-summary-article-subject)))
-
-(defun gnus-summary-next-unread-same-subject ()
- "Select next unread article which has the same subject as current one."
- (interactive)
- (gnus-set-global-variables)
- (gnus-summary-next-article t (gnus-summary-article-subject)))
-
-(defun gnus-summary-prev-unread-same-subject ()
- "Select previous unread article which has the same subject as current one."
- (interactive)
- (gnus-set-global-variables)
- (gnus-summary-prev-article t (gnus-summary-article-subject)))
-
-(defun gnus-summary-first-unread-article ()
- "Select the first unread article.
-Return nil if there are no unread articles."
- (interactive)
- (gnus-set-global-variables)
- (prog1
- (if (gnus-summary-first-subject t)
- (progn
- (gnus-summary-show-thread)
- (gnus-summary-first-subject t)
- (gnus-summary-display-article (gnus-summary-article-number))))
- (gnus-summary-position-point)))
-
-(defun gnus-summary-best-unread-article ()
- "Select the unread article with the highest score."
- (interactive)
- (gnus-set-global-variables)
- (let ((best -1000000)
- (data gnus-newsgroup-data)
- article score)
- (while data
- (and (gnus-data-unread-p (car data))
- (> (setq score
- (gnus-summary-article-score (gnus-data-number (car data))))
- best)
- (setq best score
- article (gnus-data-number (car data))))
- (setq data (cdr data)))
- (prog1
- (if article
- (gnus-summary-goto-article article)
- (error "No unread articles"))
- (gnus-summary-position-point))))
-
-(defun gnus-summary-last-subject ()
- "Go to the last displayed subject line in the group."
- (let ((article (gnus-data-number (car (gnus-data-list t)))))
- (when article
- (gnus-summary-goto-subject article))))
-
-(defun gnus-summary-goto-article (article &optional all-headers force)
- "Fetch ARTICLE and display it if it exists.
-If ALL-HEADERS is non-nil, no header lines are hidden."
- (interactive
- (list
- (string-to-int
- (completing-read
- "Article number: "
- (mapcar (lambda (number) (list (int-to-string number)))
- gnus-newsgroup-limit)))
- current-prefix-arg
- t))
- (prog1
- (if (gnus-summary-goto-subject article force)
- (gnus-summary-display-article article all-headers)
- (gnus-message 4 "Couldn't go to article %s" article) nil)
- (gnus-summary-position-point)))
-
-(defun gnus-summary-goto-last-article ()
- "Go to the previously read article."
- (interactive)
- (prog1
- (and gnus-last-article
- (gnus-summary-goto-article gnus-last-article))
- (gnus-summary-position-point)))
-
-(defun gnus-summary-pop-article (number)
- "Pop one article off the history and go to the previous.
-NUMBER articles will be popped off."
- (interactive "p")
- (let (to)
- (setq gnus-newsgroup-history
- (cdr (setq to (nthcdr number gnus-newsgroup-history))))
- (if to
- (gnus-summary-goto-article (car to))
- (error "Article history empty")))
- (gnus-summary-position-point))
-
-;; Summary commands and functions for limiting the summary buffer.
-
-(defun gnus-summary-limit-to-articles (n)
- "Limit the summary buffer to the next N articles.
-If not given a prefix, use the process marked articles instead."
- (interactive "P")
- (gnus-set-global-variables)
- (prog1
- (let ((articles (gnus-summary-work-articles n)))
- (setq gnus-newsgroup-processable nil)
- (gnus-summary-limit articles))
- (gnus-summary-position-point)))
-
-(defun gnus-summary-pop-limit (&optional total)
- "Restore the previous limit.
-If given a prefix, remove all limits."
- (interactive "P")
- (gnus-set-global-variables)
- (when total
- (setq gnus-newsgroup-limits
- (list (mapcar (lambda (h) (mail-header-number h))
- gnus-newsgroup-headers))))
- (unless gnus-newsgroup-limits
- (error "No limit to pop"))
- (prog1
- (gnus-summary-limit nil 'pop)
- (gnus-summary-position-point)))
-
-(defun gnus-summary-limit-to-subject (subject &optional header)
- "Limit the summary buffer to articles that have subjects that match a regexp."
- (interactive "sRegexp: ")
- (unless header
- (setq header "subject"))
- (when (not (equal "" subject))
- (prog1
- (let ((articles (gnus-summary-find-matching
- (or header "subject") subject 'all)))
- (or articles (error "Found no matches for \"%s\"" subject))
- (gnus-summary-limit articles))
- (gnus-summary-position-point))))
-
-(defun gnus-summary-limit-to-author (from)
- "Limit the summary buffer to articles that have authors that match a regexp."
- (interactive "sRegexp: ")
- (gnus-summary-limit-to-subject from "from"))
-
-(defalias 'gnus-summary-delete-marked-as-read 'gnus-summary-limit-to-unread)
-(make-obsolete
- 'gnus-summary-delete-marked-as-read 'gnus-summary-limit-to-unread)
-
-(defun gnus-summary-limit-to-unread (&optional all)
- "Limit the summary buffer to articles that are not marked as read.
-If ALL is non-nil, limit strictly to unread articles."
- (interactive "P")
- (if all
- (gnus-summary-limit-to-marks (char-to-string gnus-unread-mark))
- (gnus-summary-limit-to-marks
- ;; Concat all the marks that say that an article is read and have
- ;; those removed.
- (list gnus-del-mark gnus-read-mark gnus-ancient-mark
- gnus-killed-mark gnus-kill-file-mark
- gnus-low-score-mark gnus-expirable-mark
- gnus-canceled-mark gnus-catchup-mark gnus-sparse-mark)
- 'reverse)))
-
-(defalias 'gnus-summary-delete-marked-with 'gnus-summary-limit-to-marks)
-(make-obsolete 'gnus-summary-delete-marked-with 'gnus-summary-limit-to-marks)
-
-(defun gnus-summary-limit-to-marks (marks &optional reverse)
- "Limit the summary buffer to articles that are marked with MARKS (e.g. \"DK\").
-If REVERSE, limit the summary buffer to articles that are not marked
-with MARKS. MARKS can either be a string of marks or a list of marks.
-Returns how many articles were removed."
- (interactive "sMarks: ")
- (gnus-set-global-variables)
- (prog1
- (let ((data gnus-newsgroup-data)
- (marks (if (listp marks) marks
- (append marks nil))) ; Transform to list.
- articles)
- (while data
- (and (if reverse (not (memq (gnus-data-mark (car data)) marks))
- (memq (gnus-data-mark (car data)) marks))
- (setq articles (cons (gnus-data-number (car data)) articles)))
- (setq data (cdr data)))
- (gnus-summary-limit articles))
- (gnus-summary-position-point)))
-
-(defun gnus-summary-limit-to-score (&optional score)
- "Limit to articles with score at or above SCORE."
- (interactive "P")
- (gnus-set-global-variables)
- (setq score (if score
- (prefix-numeric-value score)
- (or gnus-summary-default-score 0)))
- (let ((data gnus-newsgroup-data)
- articles)
- (while data
- (when (>= (gnus-summary-article-score (gnus-data-number (car data)))
- score)
- (push (gnus-data-number (car data)) articles))
- (setq data (cdr data)))
- (prog1
- (gnus-summary-limit articles)
- (gnus-summary-position-point))))
-
-(defun gnus-summary-limit-include-dormant ()
- "Display all the hidden articles that are marked as dormant."
- (interactive)
- (gnus-set-global-variables)
- (or gnus-newsgroup-dormant
- (error "There are no dormant articles in this group"))
- (prog1
- (gnus-summary-limit (append gnus-newsgroup-dormant gnus-newsgroup-limit))
- (gnus-summary-position-point)))
-
-(defun gnus-summary-limit-exclude-dormant ()
- "Hide all dormant articles."
- (interactive)
- (gnus-set-global-variables)
- (prog1
- (gnus-summary-limit-to-marks (list gnus-dormant-mark) 'reverse)
- (gnus-summary-position-point)))
-
-(defun gnus-summary-limit-exclude-childless-dormant ()
- "Hide all dormant articles that have no children."
- (interactive)
- (gnus-set-global-variables)
- (let ((data (gnus-data-list t))
- articles d children)
- ;; Find all articles that are either not dormant or have
- ;; children.
- (while (setq d (pop data))
- (when (or (not (= (gnus-data-mark d) gnus-dormant-mark))
- (and (setq children
- (gnus-article-children (gnus-data-number d)))
- (let (found)
- (while children
- (when (memq (car children) articles)
- (setq children nil
- found t))
- (pop children))
- found)))
- (push (gnus-data-number d) articles)))
- ;; Do the limiting.
- (prog1
- (gnus-summary-limit articles)
- (gnus-summary-position-point))))
-
-(defun gnus-summary-limit-mark-excluded-as-read (&optional all)
- "Mark all unread excluded articles as read.
-If ALL, mark even excluded ticked and dormants as read."
- (interactive "P")
- (let ((articles (gnus-sorted-complement
- (sort
- (mapcar (lambda (h) (mail-header-number h))
- gnus-newsgroup-headers)
- '<)
- (sort gnus-newsgroup-limit '<)))
- article)
- (setq gnus-newsgroup-unreads nil)
- (if all
- (setq gnus-newsgroup-dormant nil
- gnus-newsgroup-marked nil
- gnus-newsgroup-reads
- (nconc
- (mapcar (lambda (n) (cons n gnus-catchup-mark)) articles)
- gnus-newsgroup-reads))
- (while (setq article (pop articles))
- (unless (or (memq article gnus-newsgroup-dormant)
- (memq article gnus-newsgroup-marked))
- (push (cons article gnus-catchup-mark) gnus-newsgroup-reads))))))
-
-(defun gnus-summary-limit (articles &optional pop)
- (if pop
- ;; We pop the previous limit off the stack and use that.
- (setq articles (car gnus-newsgroup-limits)
- gnus-newsgroup-limits (cdr gnus-newsgroup-limits))
- ;; We use the new limit, so we push the old limit on the stack.
- (setq gnus-newsgroup-limits
- (cons gnus-newsgroup-limit gnus-newsgroup-limits)))
- ;; Set the limit.
- (setq gnus-newsgroup-limit articles)
- (let ((total (length gnus-newsgroup-data))
- (data (gnus-data-find-list (gnus-summary-article-number)))
- (gnus-summary-mark-below nil) ; Inhibit this.
- found)
- ;; This will do all the work of generating the new summary buffer
- ;; according to the new limit.
- (gnus-summary-prepare)
- ;; Hide any threads, possibly.
- (and gnus-show-threads
- gnus-thread-hide-subtree
- (gnus-summary-hide-all-threads))
- ;; Try to return to the article you were at, or one in the
- ;; neighborhood.
- (if data
- ;; We try to find some article after the current one.
- (while data
- (and (gnus-summary-goto-subject
- (gnus-data-number (car data)) nil t)
- (setq data nil
- found t))
- (setq data (cdr data))))
- (or found
- ;; If there is no data, that means that we were after the last
- ;; article. The same goes when we can't find any articles
- ;; after the current one.
- (progn
- (goto-char (point-max))
- (gnus-summary-find-prev)))
- ;; We return how many articles were removed from the summary
- ;; buffer as a result of the new limit.
- (- total (length gnus-newsgroup-data))))
-
-(defsubst gnus-invisible-cut-children (threads)
- (let ((num 0))
- (while threads
- (when (memq (mail-header-number (caar threads)) gnus-newsgroup-limit)
- (incf num))
- (pop threads))
- (< num 2)))
-
-(defsubst gnus-cut-thread (thread)
- "Go forwards in the thread until we find an article that we want to display."
- (when (or (eq gnus-fetch-old-headers 'some)
- (eq gnus-build-sparse-threads 'some)
- (eq gnus-build-sparse-threads 'more))
- ;; Deal with old-fetched headers and sparse threads.
- (while (and
- thread
- (or
- (memq (mail-header-number (car thread)) gnus-newsgroup-sparse)
- (memq (mail-header-number (car thread)) gnus-newsgroup-ancient))
- (or (<= (length (cdr thread)) 1)
- (gnus-invisible-cut-children (cdr thread))))
- (setq thread (cadr thread))))
- thread)
-
-(defun gnus-cut-threads (threads)
- "Cut off all uninteresting articles from the beginning of threads."
- (when (or (eq gnus-fetch-old-headers 'some)
- (eq gnus-build-sparse-threads 'some)
- (eq gnus-build-sparse-threads 'more))
- (let ((th threads))
- (while th
- (setcar th (gnus-cut-thread (car th)))
- (setq th (cdr th)))))
- ;; Remove nixed out threads.
- (delq nil threads))
-
-(defun gnus-summary-initial-limit (&optional show-if-empty)
- "Figure out what the initial limit is supposed to be on group entry.
-This entails weeding out unwanted dormants, low-scored articles,
-fetch-old-headers verbiage, and so on."
- ;; Most groups have nothing to remove.
- (if (or gnus-inhibit-limiting
- (and (null gnus-newsgroup-dormant)
- (not (eq gnus-fetch-old-headers 'some))
- (null gnus-summary-expunge-below)
- (not (eq gnus-build-sparse-threads 'some))
- (not (eq gnus-build-sparse-threads 'more))
- (null gnus-thread-expunge-below)
- (not gnus-use-nocem)))
- () ; Do nothing.
- (push gnus-newsgroup-limit gnus-newsgroup-limits)
- (setq gnus-newsgroup-limit nil)
- (mapatoms
- (lambda (node)
- (unless (car (symbol-value node))
- ;; These threads have no parents -- they are roots.
- (let ((nodes (cdr (symbol-value node)))
- thread)
- (while nodes
- (if (and gnus-thread-expunge-below
- (< (gnus-thread-total-score (car nodes))
- gnus-thread-expunge-below))
- (gnus-expunge-thread (pop nodes))
- (setq thread (pop nodes))
- (gnus-summary-limit-children thread))))))
- gnus-newsgroup-dependencies)
- ;; If this limitation resulted in an empty group, we might
- ;; pop the previous limit and use it instead.
- (when (and (not gnus-newsgroup-limit)
- show-if-empty)
- (setq gnus-newsgroup-limit (pop gnus-newsgroup-limits)))
- gnus-newsgroup-limit))
-
-(defun gnus-summary-limit-children (thread)
- "Return 1 if this subthread is visible and 0 if it is not."
- ;; First we get the number of visible children to this thread. This
- ;; is done by recursing down the thread using this function, so this
- ;; will really go down to a leaf article first, before slowly
- ;; working its way up towards the root.
- (when thread
- (let ((children
- (if (cdr thread)
- (apply '+ (mapcar 'gnus-summary-limit-children
- (cdr thread)))
- 0))
- (number (mail-header-number (car thread)))
- score)
- (if (or
- ;; If this article is dormant and has absolutely no visible
- ;; children, then this article isn't visible.
- (and (memq number gnus-newsgroup-dormant)
- (= children 0))
- ;; If this is "fetch-old-headered" and there is only one
- ;; visible child (or less), then we don't want this article.
- (and (eq gnus-fetch-old-headers 'some)
- (memq number gnus-newsgroup-ancient)
- (zerop children))
- ;; If this is a sparsely inserted article with no children,
- ;; we don't want it.
- (and (eq gnus-build-sparse-threads 'some)
- (memq number gnus-newsgroup-sparse)
- (zerop children))
- ;; If we use expunging, and this article is really
- ;; low-scored, then we don't want this article.
- (when (and gnus-summary-expunge-below
- (< (setq score
- (or (cdr (assq number gnus-newsgroup-scored))
- gnus-summary-default-score))
- gnus-summary-expunge-below))
- ;; We increase the expunge-tally here, but that has
- ;; nothing to do with the limits, really.
- (incf gnus-newsgroup-expunged-tally)
- ;; We also mark as read here, if that's wanted.
- (when (and gnus-summary-mark-below
- (< score gnus-summary-mark-below))
- (setq gnus-newsgroup-unreads
- (delq number gnus-newsgroup-unreads))
- (if gnus-newsgroup-auto-expire
- (push number gnus-newsgroup-expirable)
- (push (cons number gnus-low-score-mark)
- gnus-newsgroup-reads)))
- t)
- (and gnus-use-nocem
- (gnus-nocem-unwanted-article-p (mail-header-id (car thread)))))
- ;; Nope, invisible article.
- 0
- ;; Ok, this article is to be visible, so we add it to the limit
- ;; and return 1.
- (setq gnus-newsgroup-limit (cons number gnus-newsgroup-limit))
- 1))))
-
-(defun gnus-expunge-thread (thread)
- "Mark all articles in THREAD as read."
- (let* ((number (mail-header-number (car thread))))
- (incf gnus-newsgroup-expunged-tally)
- ;; We also mark as read here, if that's wanted.
- (setq gnus-newsgroup-unreads
- (delq number gnus-newsgroup-unreads))
- (if gnus-newsgroup-auto-expire
- (push number gnus-newsgroup-expirable)
- (push (cons number gnus-low-score-mark)
- gnus-newsgroup-reads)))
- ;; Go recursively through all subthreads.
- (mapcar 'gnus-expunge-thread (cdr thread)))
-
-;; Summary article oriented commands
-
-(defun gnus-summary-refer-parent-article (n)
- "Refer parent article N times.
-The difference between N and the number of articles fetched is returned."
- (interactive "p")
- (gnus-set-global-variables)
- (while
- (and
- (> n 0)
- (let* ((header (gnus-summary-article-header))
- (ref
- ;; If we try to find the parent of the currently
- ;; displayed article, then we take a look at the actual
- ;; References header, since this is slightly more
- ;; reliable than the References field we got from the
- ;; server.
- (if (and (eq (mail-header-number header)
- (cdr gnus-article-current))
- (equal gnus-newsgroup-name
- (car gnus-article-current)))
- (save-excursion
- (set-buffer gnus-original-article-buffer)
- (nnheader-narrow-to-headers)
- (prog1
- (message-fetch-field "references")
- (widen)))
- ;; It's not the current article, so we take a bet on
- ;; the value we got from the server.
- (mail-header-references header))))
- (if (setq ref (or ref (mail-header-references header)))
- (or (gnus-summary-refer-article (gnus-parent-id ref))
- (gnus-message 1 "Couldn't find parent"))
- (gnus-message 1 "No references in article %d"
- (gnus-summary-article-number))
- nil)))
- (setq n (1- n)))
- (gnus-summary-position-point)
- n)
-
-(defun gnus-summary-refer-references ()
- "Fetch all articles mentioned in the References header.
-Return how many articles were fetched."
- (interactive)
- (gnus-set-global-variables)
- (let ((ref (mail-header-references (gnus-summary-article-header)))
- (current (gnus-summary-article-number))
- (n 0))
- ;; For each Message-ID in the References header...
- (while (string-match "<[^>]*>" ref)
- (incf n)
- ;; ... fetch that article.
- (gnus-summary-refer-article
- (prog1 (match-string 0 ref)
- (setq ref (substring ref (match-end 0))))))
- (gnus-summary-goto-subject current)
- (gnus-summary-position-point)
- n))
-
-(defun gnus-summary-refer-article (message-id)
- "Fetch an article specified by MESSAGE-ID."
- (interactive "sMessage-ID: ")
- (when (and (stringp message-id)
- (not (zerop (length message-id))))
- ;; Construct the correct Message-ID if necessary.
- ;; Suggested by tale@pawl.rpi.edu.
- (unless (string-match "^<" message-id)
- (setq message-id (concat "<" message-id)))
- (unless (string-match ">$" message-id)
- (setq message-id (concat message-id ">")))
- (let* ((header (gnus-id-to-header message-id))
- (sparse (and header
- (memq (mail-header-number header)
- gnus-newsgroup-sparse))))
- (if header
- (prog1
- ;; The article is present in the buffer, to we just go to it.
- (gnus-summary-goto-article
- (mail-header-number header) nil header)
- (when sparse
- (gnus-summary-update-article (mail-header-number header))))
- ;; We fetch the article
- (let ((gnus-override-method
- (and (gnus-news-group-p gnus-newsgroup-name)
- gnus-refer-article-method))
- number)
- ;; Start the special refer-article method, if necessary.
- (when (and gnus-refer-article-method
- (gnus-news-group-p gnus-newsgroup-name))
- (gnus-check-server gnus-refer-article-method))
- ;; Fetch the header, and display the article.
- (if (setq number (gnus-summary-insert-subject message-id))
- (gnus-summary-select-article nil nil nil number)
- (gnus-message 3 "Couldn't fetch article %s" message-id)))))))
-
-(defun gnus-summary-enter-digest-group (&optional force)
- "Enter a digest group based on the current article."
- (interactive "P")
- (gnus-set-global-variables)
- (gnus-summary-select-article)
- (let ((name (format "%s-%d"
- (gnus-group-prefixed-name
- gnus-newsgroup-name (list 'nndoc ""))
- gnus-current-article))
- (ogroup gnus-newsgroup-name)
- (case-fold-search t)
- (buf (current-buffer))
- dig)
- (save-excursion
- (setq dig (nnheader-set-temp-buffer " *gnus digest buffer*"))
- (insert-buffer-substring gnus-original-article-buffer)
- (narrow-to-region
- (goto-char (point-min))
- (or (search-forward "\n\n" nil t) (point)))
- (goto-char (point-min))
- (delete-matching-lines "^\\(Path\\):\\|^From ")
- (widen))
- (unwind-protect
- (if (gnus-group-read-ephemeral-group
- name `(nndoc ,name (nndoc-address
- ,(get-buffer dig))
- (nndoc-article-type ,(if force 'digest 'guess))) t)
- ;; Make all postings to this group go to the parent group.
- (nconc (gnus-info-params (gnus-get-info name))
- (list (cons 'to-group ogroup)))
- ;; Couldn't select this doc group.
- (switch-to-buffer buf)
- (gnus-set-global-variables)
- (gnus-configure-windows 'summary)
- (gnus-message 3 "Article couldn't be entered?"))
- (kill-buffer dig))))
-
-(defun gnus-summary-isearch-article (&optional regexp-p)
- "Do incremental search forward on the current article.
-If REGEXP-P (the prefix) is non-nil, do regexp isearch."
- (interactive "P")
- (gnus-set-global-variables)
- (gnus-summary-select-article)
- (gnus-configure-windows 'article)
- (gnus-eval-in-buffer-window gnus-article-buffer
- ;;(goto-char (point-min))
- (isearch-forward regexp-p)))
-
-(defun gnus-summary-search-article-forward (regexp &optional backward)
- "Search for an article containing REGEXP forward.
-If BACKWARD, search backward instead."
- (interactive
- (list (read-string
- (format "Search article %s (regexp%s): "
- (if current-prefix-arg "backward" "forward")
- (if gnus-last-search-regexp
- (concat ", default " gnus-last-search-regexp)
- "")))
- current-prefix-arg))
- (gnus-set-global-variables)
- (if (string-equal regexp "")
- (setq regexp (or gnus-last-search-regexp ""))
- (setq gnus-last-search-regexp regexp))
- (unless (gnus-summary-search-article regexp backward)
- (error "Search failed: \"%s\"" regexp)))
-
-(defun gnus-summary-search-article-backward (regexp)
- "Search for an article containing REGEXP backward."
- (interactive
- (list (read-string
- (format "Search article backward (regexp%s): "
- (if gnus-last-search-regexp
- (concat ", default " gnus-last-search-regexp)
- "")))))
- (gnus-summary-search-article-forward regexp 'backward))
-
-(defun gnus-summary-search-article (regexp &optional backward)
- "Search for an article containing REGEXP.
-Optional argument BACKWARD means do search for backward.
-`gnus-select-article-hook' is not called during the search."
- (let ((gnus-select-article-hook nil) ;Disable hook.
- (gnus-article-display-hook nil)
- (gnus-mark-article-hook nil) ;Inhibit marking as read.
- (re-search
- (if backward
- 're-search-backward 're-search-forward))
- (sum (current-buffer))
- (found nil))
- (gnus-save-hidden-threads
- (gnus-summary-select-article)
- (set-buffer gnus-article-buffer)
- (when backward
- (forward-line -1))
- (while (not found)
- (gnus-message 7 "Searching article: %d..." (cdr gnus-article-current))
- (if (if backward
- (re-search-backward regexp nil t)
- (re-search-forward regexp nil t))
- ;; We found the regexp.
- (progn
- (setq found 'found)
- (beginning-of-line)
- (set-window-start
- (get-buffer-window (current-buffer))
- (point))
- (forward-line 1)
- (set-buffer sum))
- ;; We didn't find it, so we go to the next article.
- (set-buffer sum)
- (if (not (if backward (gnus-summary-find-prev)
- (gnus-summary-find-next)))
- ;; No more articles.
- (setq found t)
- ;; Select the next article and adjust point.
- (gnus-summary-select-article)
- (set-buffer gnus-article-buffer)
- (widen)
- (goto-char (if backward (point-max) (point-min))))))
- (gnus-message 7 ""))
- ;; Return whether we found the regexp.
- (when (eq found 'found)
- (gnus-summary-show-thread)
- (gnus-summary-goto-subject gnus-current-article)
- (gnus-summary-position-point)
- t)))
-
-(defun gnus-summary-find-matching (header regexp &optional backward unread
- not-case-fold)
- "Return a list of all articles that match REGEXP on HEADER.
-The search stars on the current article and goes forwards unless
-BACKWARD is non-nil. If BACKWARD is `all', do all articles.
-If UNREAD is non-nil, only unread articles will
-be taken into consideration. If NOT-CASE-FOLD, case won't be folded
-in the comparisons."
- (let ((data (if (eq backward 'all) gnus-newsgroup-data
- (gnus-data-find-list
- (gnus-summary-article-number) (gnus-data-list backward))))
- (func `(lambda (h) (,(intern (concat "mail-header-" header)) h)))
- (case-fold-search (not not-case-fold))
- articles d)
- (or (fboundp (intern (concat "mail-header-" header)))
- (error "%s is not a valid header" header))
- (while data
- (setq d (car data))
- (and (or (not unread) ; We want all articles...
- (gnus-data-unread-p d)) ; Or just unreads.
- (vectorp (gnus-data-header d)) ; It's not a pseudo.
- (string-match regexp (funcall func (gnus-data-header d))) ; Match.
- (setq articles (cons (gnus-data-number d) articles))) ; Success!
- (setq data (cdr data)))
- (nreverse articles)))
-
-(defun gnus-summary-execute-command (header regexp command &optional backward)
- "Search forward for an article whose HEADER matches REGEXP and execute COMMAND.
-If HEADER is an empty string (or nil), the match is done on the entire
-article. If BACKWARD (the prefix) is non-nil, search backward instead."
- (interactive
- (list (let ((completion-ignore-case t))
- (completing-read
- "Header name: "
- (mapcar (lambda (string) (list string))
- '("Number" "Subject" "From" "Lines" "Date"
- "Message-ID" "Xref" "References" "Body"))
- nil 'require-match))
- (read-string "Regexp: ")
- (read-key-sequence "Command: ")
- current-prefix-arg))
- (when (equal header "Body")
- (setq header ""))
- (gnus-set-global-variables)
- ;; Hidden thread subtrees must be searched as well.
- (gnus-summary-show-all-threads)
- ;; We don't want to change current point nor window configuration.
- (save-excursion
- (save-window-excursion
- (gnus-message 6 "Executing %s..." (key-description command))
- ;; We'd like to execute COMMAND interactively so as to give arguments.
- (gnus-execute header regexp
- `(lambda () (call-interactively ',(key-binding command)))
- backward)
- (gnus-message 6 "Executing %s...done" (key-description command)))))
-
-(defun gnus-summary-beginning-of-article ()
- "Scroll the article back to the beginning."
- (interactive)
- (gnus-set-global-variables)
- (gnus-summary-select-article)
- (gnus-configure-windows 'article)
- (gnus-eval-in-buffer-window gnus-article-buffer
- (widen)
- (goto-char (point-min))
- (and gnus-break-pages (gnus-narrow-to-page))))
-
-(defun gnus-summary-end-of-article ()
- "Scroll to the end of the article."
- (interactive)
- (gnus-set-global-variables)
- (gnus-summary-select-article)
- (gnus-configure-windows 'article)
- (gnus-eval-in-buffer-window gnus-article-buffer
- (widen)
- (goto-char (point-max))
- (recenter -3)
- (and gnus-break-pages (gnus-narrow-to-page))))
-
-(defun gnus-summary-show-article (&optional arg)
- "Force re-fetching of the current article.
-If ARG (the prefix) is non-nil, show the raw article without any
-article massaging functions being run."
- (interactive "P")
- (gnus-set-global-variables)
- (if (not arg)
- ;; Select the article the normal way.
- (gnus-summary-select-article nil 'force)
- ;; Bind the article treatment functions to nil.
- (let ((gnus-have-all-headers t)
- gnus-article-display-hook
- gnus-article-prepare-hook
- gnus-break-pages
- gnus-visual)
- (gnus-summary-select-article nil 'force)))
- (gnus-summary-goto-subject gnus-current-article)
-; (gnus-configure-windows 'article)
- (gnus-summary-position-point))
-
-(defun gnus-summary-verbose-headers (&optional arg)
- "Toggle permanent full header display.
-If ARG is a positive number, turn header display on.
-If ARG is a negative number, turn header display off."
- (interactive "P")
- (gnus-set-global-variables)
- (gnus-summary-toggle-header arg)
- (setq gnus-show-all-headers
- (cond ((or (not (numberp arg))
- (zerop arg))
- (not gnus-show-all-headers))
- ((natnump arg)
- t))))
-
-(defun gnus-summary-toggle-header (&optional arg)
- "Show the headers if they are hidden, or hide them if they are shown.
-If ARG is a positive number, show the entire header.
-If ARG is a negative number, hide the unwanted header lines."
- (interactive "P")
- (gnus-set-global-variables)
- (save-excursion
- (set-buffer gnus-article-buffer)
- (let* ((buffer-read-only nil)
- (inhibit-point-motion-hooks t)
- (hidden (text-property-any
- (goto-char (point-min)) (search-forward "\n\n")
- 'invisible t))
- e)
- (goto-char (point-min))
- (when (search-forward "\n\n" nil t)
- (delete-region (point-min) (1- (point))))
- (goto-char (point-min))
- (save-excursion
- (set-buffer gnus-original-article-buffer)
- (goto-char (point-min))
- (setq e (1- (or (search-forward "\n\n" nil t) (point-max)))))
- (insert-buffer-substring gnus-original-article-buffer 1 e)
- (let ((gnus-inhibit-hiding t))
- (run-hooks 'gnus-article-display-hook))
- (if (or (not hidden) (and (numberp arg) (< arg 0)))
- (gnus-article-hide-headers)))))
-
-(defun gnus-summary-show-all-headers ()
- "Make all header lines visible."
- (interactive)
- (gnus-set-global-variables)
- (gnus-article-show-all-headers))
-
-(defun gnus-summary-toggle-mime (&optional arg)
- "Toggle MIME processing.
-If ARG is a positive number, turn MIME processing on."
- (interactive "P")
- (gnus-set-global-variables)
- (setq gnus-show-mime
- (if (null arg) (not gnus-show-mime)
- (> (prefix-numeric-value arg) 0)))
- (gnus-summary-select-article t 'force))
-
-(defun gnus-summary-caesar-message (&optional arg)
- "Caesar rotate the current article by 13.
-The numerical prefix specifies how manu places to rotate each letter
-forward."
- (interactive "P")
- (gnus-set-global-variables)
- (gnus-summary-select-article)
- (let ((mail-header-separator ""))
- (gnus-eval-in-buffer-window gnus-article-buffer
- (save-restriction
- (widen)
- (let ((start (window-start))
- buffer-read-only)
- (message-caesar-buffer-body arg)
- (set-window-start (get-buffer-window (current-buffer)) start))))))
-
-(defun gnus-summary-stop-page-breaking ()
- "Stop page breaking in the current article."
- (interactive)
- (gnus-set-global-variables)
- (gnus-summary-select-article)
- (gnus-eval-in-buffer-window gnus-article-buffer
- (widen)))
-
-(defun gnus-summary-move-article (&optional n to-newsgroup select-method action)
- "Move the current article to a different newsgroup.
-If N is a positive number, move the N next articles.
-If N is a negative number, move the N previous articles.
-If N is nil and any articles have been marked with the process mark,
-move those articles instead.
-If TO-NEWSGROUP is string, do not prompt for a newsgroup to move to.
-If SELECT-METHOD is non-nil, do not move to a specific newsgroup, but
-re-spool using this method.
-
-For this function to work, both the current newsgroup and the
-newsgroup that you want to move to have to support the `request-move'
-and `request-accept' functions."
- (interactive "P")
- (unless action (setq action 'move))
- (gnus-set-global-variables)
- ;; Check whether the source group supports the required functions.
- (cond ((and (eq action 'move)
- (not (gnus-check-backend-function
- 'request-move-article gnus-newsgroup-name)))
- (error "The current group does not support article moving"))
- ((and (eq action 'crosspost)
- (not (gnus-check-backend-function
- 'request-replace-article gnus-newsgroup-name)))
- (error "The current group does not support article editing")))
- (let ((articles (gnus-summary-work-articles n))
- (prefix (gnus-group-real-prefix gnus-newsgroup-name))
- (names '((move "Move" "Moving")
- (copy "Copy" "Copying")
- (crosspost "Crosspost" "Crossposting")))
- (copy-buf (save-excursion
- (nnheader-set-temp-buffer " *copy article*")))
- art-group to-method new-xref article to-groups)
- (unless (assq action names)
- (error "Unknown action %s" action))
- ;; Read the newsgroup name.
- (when (and (not to-newsgroup)
- (not select-method))
- (setq to-newsgroup
- (gnus-read-move-group-name
- (cadr (assq action names))
- (symbol-value (intern (format "gnus-current-%s-group" action)))
- articles prefix))
- (set (intern (format "gnus-current-%s-group" action)) to-newsgroup))
- (setq to-method (or select-method
- (gnus-group-name-to-method to-newsgroup)))
- ;; Check the method we are to move this article to...
- (or (gnus-check-backend-function 'request-accept-article (car to-method))
- (error "%s does not support article copying" (car to-method)))
- (or (gnus-check-server to-method)
- (error "Can't open server %s" (car to-method)))
- (gnus-message 6 "%s to %s: %s..."
- (caddr (assq action names))
- (or (car select-method) to-newsgroup) articles)
- (while articles
- (setq article (pop articles))
- (setq
- art-group
- (cond
- ;; Move the article.
- ((eq action 'move)
- (gnus-request-move-article
- article ; Article to move
- gnus-newsgroup-name ; From newsgrouo
- (nth 1 (gnus-find-method-for-group
- gnus-newsgroup-name)) ; Server
- (list 'gnus-request-accept-article
- to-newsgroup (list 'quote select-method)
- (not articles)) ; Accept form
- (not articles))) ; Only save nov last time
- ;; Copy the article.
- ((eq action 'copy)
- (save-excursion
- (set-buffer copy-buf)
- (gnus-request-article-this-buffer article gnus-newsgroup-name)
- (gnus-request-accept-article
- to-newsgroup select-method (not articles))))
- ;; Crosspost the article.
- ((eq action 'crosspost)
- (let ((xref (mail-header-xref (gnus-summary-article-header article))))
- (setq new-xref (concat gnus-newsgroup-name ":" article))
- (if (and xref (not (string= xref "")))
- (progn
- (when (string-match "^Xref: " xref)
- (setq xref (substring xref (match-end 0))))
- (setq new-xref (concat xref " " new-xref)))
- (setq new-xref (concat (system-name) " " new-xref)))
- (save-excursion
- (set-buffer copy-buf)
- (gnus-request-article-this-buffer article gnus-newsgroup-name)
- (nnheader-replace-header "xref" new-xref)
- (gnus-request-accept-article
- to-newsgroup select-method (not articles)))))))
- (if (not art-group)
- (gnus-message 1 "Couldn't %s article %s"
- (cadr (assq action names)) article)
- (let* ((entry
- (or
- (gnus-gethash (car art-group) gnus-newsrc-hashtb)
- (gnus-gethash
- (gnus-group-prefixed-name
- (car art-group)
- (or select-method
- (gnus-find-method-for-group to-newsgroup)))
- gnus-newsrc-hashtb)))
- (info (nth 2 entry))
- (to-group (gnus-info-group info)))
- ;; Update the group that has been moved to.
- (when (and info
- (memq action '(move copy)))
- (unless (member to-group to-groups)
- (push to-group to-groups))
-
- (unless (memq article gnus-newsgroup-unreads)
- (gnus-info-set-read
- info (gnus-add-to-range (gnus-info-read info)
- (list (cdr art-group)))))
-
- ;; Copy any marks over to the new group.
- (let ((marks gnus-article-mark-lists)
- (to-article (cdr art-group)))
-
- ;; See whether the article is to be put in the cache.
- (when gnus-use-cache
- (gnus-cache-possibly-enter-article
- to-group to-article
- (let ((header (copy-sequence
- (gnus-summary-article-header article))))
- (mail-header-set-number header to-article)
- header)
- (memq article gnus-newsgroup-marked)
- (memq article gnus-newsgroup-dormant)
- (memq article gnus-newsgroup-unreads)))
-
- (while marks
- (when (memq article (symbol-value
- (intern (format "gnus-newsgroup-%s"
- (caar marks)))))
- ;; If the other group is the same as this group,
- ;; then we have to add the mark to the list.
- (when (equal to-group gnus-newsgroup-name)
- (set (intern (format "gnus-newsgroup-%s" (caar marks)))
- (cons to-article
- (symbol-value
- (intern (format "gnus-newsgroup-%s"
- (caar marks)))))))
- ;; Copy mark to other group.
- (gnus-add-marked-articles
- to-group (cdar marks) (list to-article) info))
- (setq marks (cdr marks)))))
-
- ;; Update the Xref header in this article to point to
- ;; the new crossposted article we have just created.
- (when (eq action 'crosspost)
- (save-excursion
- (set-buffer copy-buf)
- (gnus-request-article-this-buffer article gnus-newsgroup-name)
- (nnheader-replace-header
- "xref" (concat new-xref " " (gnus-group-prefixed-name
- (car art-group) to-method)
- ":" (cdr art-group)))
- (gnus-request-replace-article
- article gnus-newsgroup-name (current-buffer)))))
-
- (gnus-summary-goto-subject article)
- (when (eq action 'move)
- (gnus-summary-mark-article article gnus-canceled-mark)))
- (gnus-summary-remove-process-mark article))
- ;; Re-activate all groups that have been moved to.
- (while to-groups
- (gnus-activate-group (pop to-groups)))
-
- (gnus-kill-buffer copy-buf)
- (gnus-summary-position-point)
- (gnus-set-mode-line 'summary)))
-
-(defun gnus-summary-copy-article (&optional n to-newsgroup select-method)
- "Move the current article to a different newsgroup.
-If TO-NEWSGROUP is string, do not prompt for a newsgroup to move to.
-If SELECT-METHOD is non-nil, do not move to a specific newsgroup, but
-re-spool using this method."
- (interactive "P")
- (gnus-summary-move-article n nil select-method 'copy))
-
-(defun gnus-summary-crosspost-article (&optional n)
- "Crosspost the current article to some other group."
- (interactive "P")
- (gnus-summary-move-article n nil nil 'crosspost))
-
-(defvar gnus-summary-respool-default-method nil
- "Default method for respooling an article.
-If nil, use to the current newsgroup method.")
-
-(defun gnus-summary-respool-article (&optional n method)
- "Respool the current article.
-The article will be squeezed through the mail spooling process again,
-which means that it will be put in some mail newsgroup or other
-depending on `nnmail-split-methods'.
-If N is a positive number, respool the N next articles.
-If N is a negative number, respool the N previous articles.
-If N is nil and any articles have been marked with the process mark,
-respool those articles instead.
-
-Respooling can be done both from mail groups and \"real\" newsgroups.
-In the former case, the articles in question will be moved from the
-current group into whatever groups they are destined to. In the
-latter case, they will be copied into the relevant groups."
- (interactive
- (list current-prefix-arg
- (let* ((methods (gnus-methods-using 'respool))
- (methname
- (symbol-name (or gnus-summary-respool-default-method
- (car (gnus-find-method-for-group
- gnus-newsgroup-name)))))
- (method
- (gnus-completing-read
- methname "What backend do you want to use when respooling?"
- methods nil t nil 'gnus-method-history))
- ms)
- (cond
- ((zerop (length (setq ms (gnus-servers-using-backend method))))
- (list (intern method) ""))
- ((= 1 (length ms))
- (car ms))
- (t
- (cdr (completing-read
- "Server name: "
- (mapcar (lambda (m) (cons (cadr m) m)) ms) nil t)))))))
- (gnus-set-global-variables)
- (unless method
- (error "No method given for respooling"))
- (if (assoc (symbol-name
- (car (gnus-find-method-for-group gnus-newsgroup-name)))
- (gnus-methods-using 'respool))
- (gnus-summary-move-article n nil method)
- (gnus-summary-copy-article n nil method)))
-
-(defun gnus-summary-import-article (file)
- "Import a random file into a mail newsgroup."
- (interactive "fImport file: ")
- (gnus-set-global-variables)
- (let ((group gnus-newsgroup-name)
- (now (current-time))
- atts lines)
- (or (gnus-check-backend-function 'request-accept-article group)
- (error "%s does not support article importing" group))
- (or (file-readable-p file)
- (not (file-regular-p file))
- (error "Can't read %s" file))
- (save-excursion
- (set-buffer (get-buffer-create " *import file*"))
- (buffer-disable-undo (current-buffer))
- (erase-buffer)
- (insert-file-contents file)
- (goto-char (point-min))
- (unless (nnheader-article-p)
- ;; This doesn't look like an article, so we fudge some headers.
- (setq atts (file-attributes file)
- lines (count-lines (point-min) (point-max)))
- (insert "From: " (read-string "From: ") "\n"
- "Subject: " (read-string "Subject: ") "\n"
- "Date: " (timezone-make-date-arpa-standard
- (current-time-string (nth 5 atts))
- (current-time-zone now)
- (current-time-zone now)) "\n"
- "Message-ID: " (message-make-message-id) "\n"
- "Lines: " (int-to-string lines) "\n"
- "Chars: " (int-to-string (nth 7 atts)) "\n\n"))
- (gnus-request-accept-article group nil t)
- (kill-buffer (current-buffer)))))
-
-(defun gnus-summary-expire-articles (&optional now)
- "Expire all articles that are marked as expirable in the current group."
- (interactive)
- (gnus-set-global-variables)
- (when (gnus-check-backend-function
- 'request-expire-articles gnus-newsgroup-name)
- ;; This backend supports expiry.
- (let* ((total (gnus-group-total-expirable-p gnus-newsgroup-name))
- (expirable (if total
- (gnus-list-of-read-articles gnus-newsgroup-name)
- (setq gnus-newsgroup-expirable
- (sort gnus-newsgroup-expirable '<))))
- (expiry-wait (if now 'immediate
- (gnus-group-get-parameter
- gnus-newsgroup-name 'expiry-wait)))
- es)
- (when expirable
- ;; There are expirable articles in this group, so we run them
- ;; through the expiry process.
- (gnus-message 6 "Expiring articles...")
- ;; The list of articles that weren't expired is returned.
- (if expiry-wait
- (let ((nnmail-expiry-wait-function nil)
- (nnmail-expiry-wait expiry-wait))
- (setq es (gnus-request-expire-articles
- expirable gnus-newsgroup-name)))
- (setq es (gnus-request-expire-articles
- expirable gnus-newsgroup-name)))
- (or total (setq gnus-newsgroup-expirable es))
- ;; We go through the old list of expirable, and mark all
- ;; really expired articles as nonexistent.
- (unless (eq es expirable) ;If nothing was expired, we don't mark.
- (let ((gnus-use-cache nil))
- (while expirable
- (unless (memq (car expirable) es)
- (when (gnus-data-find (car expirable))
- (gnus-summary-mark-article
- (car expirable) gnus-canceled-mark)))
- (setq expirable (cdr expirable)))))
- (gnus-message 6 "Expiring articles...done")))))
-
-(defun gnus-summary-expire-articles-now ()
- "Expunge all expirable articles in the current group.
-This means that *all* articles that are marked as expirable will be
-deleted forever, right now."
- (interactive)
- (gnus-set-global-variables)
- (or gnus-expert-user
- (gnus-y-or-n-p
- "Are you really, really, really sure you want to delete all these messages? ")
- (error "Phew!"))
- (gnus-summary-expire-articles t))
-
-;; Suggested by Jack Vinson <vinson@unagi.cis.upenn.edu>.
-(defun gnus-summary-delete-article (&optional n)
- "Delete the N next (mail) articles.
-This command actually deletes articles. This is not a marking
-command. The article will disappear forever from your life, never to
-return.
-If N is negative, delete backwards.
-If N is nil and articles have been marked with the process mark,
-delete these instead."
- (interactive "P")
- (gnus-set-global-variables)
- (or (gnus-check-backend-function 'request-expire-articles
- gnus-newsgroup-name)
- (error "The current newsgroup does not support article deletion."))
- ;; Compute the list of articles to delete.
- (let ((articles (gnus-summary-work-articles n))
- not-deleted)
- (if (and gnus-novice-user
- (not (gnus-y-or-n-p
- (format "Do you really want to delete %s forever? "
- (if (> (length articles) 1)
- (format "these %s articles" (length articles))
- "this article")))))
- ()
- ;; Delete the articles.
- (setq not-deleted (gnus-request-expire-articles
- articles gnus-newsgroup-name 'force))
- (while articles
- (gnus-summary-remove-process-mark (car articles))
- ;; The backend might not have been able to delete the article
- ;; after all.
- (or (memq (car articles) not-deleted)
- (gnus-summary-mark-article (car articles) gnus-canceled-mark))
- (setq articles (cdr articles))))
- (gnus-summary-position-point)
- (gnus-set-mode-line 'summary)
- not-deleted))
-
-(defun gnus-summary-edit-article (&optional force)
- "Enter into a buffer and 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")
- (save-excursion
- (set-buffer gnus-summary-buffer)
- (gnus-set-global-variables)
- (when (and (not force)
- (gnus-group-read-only-p))
- (error "The current newsgroup does not support article editing."))
- (gnus-summary-select-article t nil t)
- (gnus-configure-windows 'article)
- (select-window (get-buffer-window gnus-article-buffer))
- (gnus-message 6 "C-c C-c to end edits")
- (setq buffer-read-only nil)
- (text-mode)
- (use-local-map (copy-keymap (current-local-map)))
- (local-set-key "\C-c\C-c" 'gnus-summary-edit-article-done)
- (buffer-enable-undo)
- (widen)
- (goto-char (point-min))
- (search-forward "\n\n" nil t)))
-
-(defun gnus-summary-edit-article-done ()
- "Make edits to the current article permanent."
- (interactive)
- (if (gnus-group-read-only-p)
- (progn
- (let ((beep (not (eq major-mode 'text-mode))))
- (gnus-summary-edit-article-postpone)
- (when beep
- (gnus-error
- 3 "The current newsgroup does not support article editing."))))
- (let ((buf (format "%s" (buffer-string))))
- (erase-buffer)
- (insert buf)
- (if (not (gnus-request-replace-article
- (cdr gnus-article-current) (car gnus-article-current)
- (current-buffer)))
- (error "Couldn't replace article.")
- (gnus-article-mode)
- (use-local-map gnus-article-mode-map)
- (setq buffer-read-only t)
- (buffer-disable-undo (current-buffer))
- (gnus-configure-windows 'summary)
- (gnus-summary-update-article (cdr gnus-article-current))
- (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))))
- (save-excursion
- (when (get-buffer gnus-original-article-buffer)
- (set-buffer gnus-original-article-buffer)
- (setq gnus-original-article nil)))
- (setq gnus-article-current nil
- gnus-current-article nil)
- (run-hooks 'gnus-article-display-hook)
- (and (gnus-visual-p 'summary-highlight 'highlight)
- (run-hooks 'gnus-visual-mark-article-hook)))))
-
-(defun gnus-summary-edit-article-postpone ()
- "Postpone changes to the current article."
- (interactive)
- (gnus-article-mode)
- (use-local-map gnus-article-mode-map)
- (setq buffer-read-only t)
- (buffer-disable-undo (current-buffer))
- (gnus-configure-windows 'summary)
- (and (gnus-visual-p 'summary-highlight 'highlight)
- (run-hooks 'gnus-visual-mark-article-hook)))
-
-(defun gnus-summary-respool-query ()
- "Query where the respool algorithm would put this article."
- (interactive)
- (gnus-set-global-variables)
- (gnus-summary-select-article)
- (save-excursion
- (set-buffer gnus-article-buffer)
- (save-restriction
- (goto-char (point-min))
- (search-forward "\n\n")
- (narrow-to-region (point-min) (point))
- (pp-eval-expression
- (list 'quote (mapcar 'car (nnmail-article-group 'identity)))))))
-
-;; Summary marking commands.
-
-(defun gnus-summary-kill-same-subject-and-select (&optional unmark)
- "Mark articles which has the same subject as read, and then select the next.
-If UNMARK is positive, remove any kind of mark.
-If UNMARK is negative, tick articles."
- (interactive "P")
- (gnus-set-global-variables)
- (if unmark
- (setq unmark (prefix-numeric-value unmark)))
- (let ((count
- (gnus-summary-mark-same-subject
- (gnus-summary-article-subject) unmark)))
- ;; Select next unread article. If auto-select-same mode, should
- ;; select the first unread article.
- (gnus-summary-next-article t (and gnus-auto-select-same
- (gnus-summary-article-subject)))
- (gnus-message 7 "%d article%s marked as %s"
- count (if (= count 1) " is" "s are")
- (if unmark "unread" "read"))))
-
-(defun gnus-summary-kill-same-subject (&optional unmark)
- "Mark articles which has the same subject as read.
-If UNMARK is positive, remove any kind of mark.
-If UNMARK is negative, tick articles."
- (interactive "P")
- (gnus-set-global-variables)
- (if unmark
- (setq unmark (prefix-numeric-value unmark)))
- (let ((count
- (gnus-summary-mark-same-subject
- (gnus-summary-article-subject) unmark)))
- ;; If marked as read, go to next unread subject.
- (if (null unmark)
- ;; Go to next unread subject.
- (gnus-summary-next-subject 1 t))
- (gnus-message 7 "%d articles are marked as %s"
- count (if unmark "unread" "read"))))
-
-(defun gnus-summary-mark-same-subject (subject &optional unmark)
- "Mark articles with same SUBJECT as read, and return marked number.
-If optional argument UNMARK is positive, remove any kinds of marks.
-If optional argument UNMARK is negative, mark articles as unread instead."
- (let ((count 1))
- (save-excursion
- (cond
- ((null unmark) ; Mark as read.
- (while (and
- (progn
- (gnus-summary-mark-article-as-read gnus-killed-mark)
- (gnus-summary-show-thread) t)
- (gnus-summary-find-subject subject))
- (setq count (1+ count))))
- ((> unmark 0) ; Tick.
- (while (and
- (progn
- (gnus-summary-mark-article-as-unread gnus-ticked-mark)
- (gnus-summary-show-thread) t)
- (gnus-summary-find-subject subject))
- (setq count (1+ count))))
- (t ; Mark as unread.
- (while (and
- (progn
- (gnus-summary-mark-article-as-unread gnus-unread-mark)
- (gnus-summary-show-thread) t)
- (gnus-summary-find-subject subject))
- (setq count (1+ count)))))
- (gnus-set-mode-line 'summary)
- ;; Return the number of marked articles.
- count)))
-
-(defun gnus-summary-mark-as-processable (n &optional unmark)
- "Set the process mark on the next N articles.
-If N is negative, mark backward instead. If UNMARK is non-nil, remove
-the process mark instead. The difference between N and the actual
-number of articles marked is returned."
- (interactive "p")
- (gnus-set-global-variables)
- (let ((backward (< n 0))
- (n (abs n)))
- (while (and
- (> n 0)
- (if unmark
- (gnus-summary-remove-process-mark
- (gnus-summary-article-number))
- (gnus-summary-set-process-mark (gnus-summary-article-number)))
- (zerop (gnus-summary-next-subject (if backward -1 1) nil t)))
- (setq n (1- n)))
- (if (/= 0 n) (gnus-message 7 "No more articles"))
- (gnus-summary-recenter)
- (gnus-summary-position-point)
- n))
-
-(defun gnus-summary-unmark-as-processable (n)
- "Remove the process mark from the next N articles.
-If N is negative, mark backward instead. The difference between N and
-the actual number of articles marked is returned."
- (interactive "p")
- (gnus-set-global-variables)
- (gnus-summary-mark-as-processable n t))
-
-(defun gnus-summary-unmark-all-processable ()
- "Remove the process mark from all articles."
- (interactive)
- (gnus-set-global-variables)
- (save-excursion
- (while gnus-newsgroup-processable
- (gnus-summary-remove-process-mark (car gnus-newsgroup-processable))))
- (gnus-summary-position-point))
-
-(defun gnus-summary-mark-as-expirable (n)
- "Mark N articles forward as expirable.
-If N is negative, mark backward instead. The difference between N and
-the actual number of articles marked is returned."
- (interactive "p")
- (gnus-set-global-variables)
- (gnus-summary-mark-forward n gnus-expirable-mark))
-
-(defun gnus-summary-mark-article-as-replied (article)
- "Mark ARTICLE replied and update the summary line."
- (setq gnus-newsgroup-replied (cons article gnus-newsgroup-replied))
- (let ((buffer-read-only nil))
- (when (gnus-summary-goto-subject article)
- (gnus-summary-update-secondary-mark article))))
-
-(defun gnus-summary-set-bookmark (article)
- "Set a bookmark in current article."
- (interactive (list (gnus-summary-article-number)))
- (gnus-set-global-variables)
- (if (or (not (get-buffer gnus-article-buffer))
- (not gnus-current-article)
- (not gnus-article-current)
- (not (equal gnus-newsgroup-name (car gnus-article-current))))
- (error "No current article selected"))
- ;; Remove old bookmark, if one exists.
- (let ((old (assq article gnus-newsgroup-bookmarks)))
- (if old (setq gnus-newsgroup-bookmarks
- (delq old gnus-newsgroup-bookmarks))))
- ;; Set the new bookmark, which is on the form
- ;; (article-number . line-number-in-body).
- (setq gnus-newsgroup-bookmarks
- (cons
- (cons article
- (save-excursion
- (set-buffer gnus-article-buffer)
- (count-lines
- (min (point)
- (save-excursion
- (goto-char (point-min))
- (search-forward "\n\n" nil t)
- (point)))
- (point))))
- gnus-newsgroup-bookmarks))
- (gnus-message 6 "A bookmark has been added to the current article."))
-
-(defun gnus-summary-remove-bookmark (article)
- "Remove the bookmark from the current article."
- (interactive (list (gnus-summary-article-number)))
- (gnus-set-global-variables)
- ;; Remove old bookmark, if one exists.
- (let ((old (assq article gnus-newsgroup-bookmarks)))
- (if old
- (progn
- (setq gnus-newsgroup-bookmarks
- (delq old gnus-newsgroup-bookmarks))
- (gnus-message 6 "Removed bookmark."))
- (gnus-message 6 "No bookmark in current article."))))
-
-;; Suggested by Daniel Quinlan <quinlan@best.com>.
-(defun gnus-summary-mark-as-dormant (n)
- "Mark N articles forward as dormant.
-If N is negative, mark backward instead. The difference between N and
-the actual number of articles marked is returned."
- (interactive "p")
- (gnus-set-global-variables)
- (gnus-summary-mark-forward n gnus-dormant-mark))
-
-(defun gnus-summary-set-process-mark (article)
- "Set the process mark on ARTICLE and update the summary line."
- (setq gnus-newsgroup-processable
- (cons article
- (delq article gnus-newsgroup-processable)))
- (when (gnus-summary-goto-subject article)
- (gnus-summary-show-thread)
- (gnus-summary-update-secondary-mark article)))
-
-(defun gnus-summary-remove-process-mark (article)
- "Remove the process mark from ARTICLE and update the summary line."
- (setq gnus-newsgroup-processable (delq article gnus-newsgroup-processable))
- (when (gnus-summary-goto-subject article)
- (gnus-summary-show-thread)
- (gnus-summary-update-secondary-mark article)))
-
-(defun gnus-summary-set-saved-mark (article)
- "Set the process mark on ARTICLE and update the summary line."
- (push article gnus-newsgroup-saved)
- (when (gnus-summary-goto-subject article)
- (gnus-summary-update-secondary-mark article)))
-
-(defun gnus-summary-mark-forward (n &optional mark no-expire)
- "Mark N articles as read forwards.
-If N is negative, mark backwards instead. Mark with MARK, ?r by default.
-The difference between N and the actual number of articles marked is
-returned."
- (interactive "p")
- (gnus-set-global-variables)
- (let ((backward (< n 0))
- (gnus-summary-goto-unread
- (and gnus-summary-goto-unread
- (not (eq gnus-summary-goto-unread 'never))
- (not (memq mark (list gnus-unread-mark
- gnus-ticked-mark gnus-dormant-mark)))))
- (n (abs n))
- (mark (or mark gnus-del-mark)))
- (while (and (> n 0)
- (gnus-summary-mark-article nil mark no-expire)
- (zerop (gnus-summary-next-subject
- (if backward -1 1)
- (and gnus-summary-goto-unread
- (not (eq gnus-summary-goto-unread 'never)))
- t)))
- (setq n (1- n)))
- (if (/= 0 n) (gnus-message 7 "No more %sarticles" (if mark "" "unread ")))
- (gnus-summary-recenter)
- (gnus-summary-position-point)
- (gnus-set-mode-line 'summary)
- n))
-
-(defun gnus-summary-mark-article-as-read (mark)
- "Mark the current article quickly as read with MARK."
- (let ((article (gnus-summary-article-number)))
- (setq gnus-newsgroup-unreads (delq article gnus-newsgroup-unreads))
- (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked))
- (setq gnus-newsgroup-dormant (delq article gnus-newsgroup-dormant))
- (setq gnus-newsgroup-reads
- (cons (cons article mark) gnus-newsgroup-reads))
- ;; Possibly remove from cache, if that is used.
- (and gnus-use-cache (gnus-cache-enter-remove-article article))
- ;; Allow the backend to change the mark.
- (setq mark (gnus-request-update-mark gnus-newsgroup-name article mark))
- ;; Check for auto-expiry.
- (when (and gnus-newsgroup-auto-expire
- (or (= mark gnus-killed-mark) (= mark gnus-del-mark)
- (= mark gnus-catchup-mark) (= mark gnus-low-score-mark)
- (= mark gnus-ancient-mark)
- (= mark gnus-read-mark) (= mark gnus-souped-mark)))
- (setq mark gnus-expirable-mark)
- (push article gnus-newsgroup-expirable))
- ;; Set the mark in the buffer.
- (gnus-summary-update-mark mark 'unread)
- t))
-
-(defun gnus-summary-mark-article-as-unread (mark)
- "Mark the current article quickly as unread with MARK."
- (let ((article (gnus-summary-article-number)))
- (if (< article 0)
- (gnus-error 1 "Unmarkable article")
- (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked))
- (setq gnus-newsgroup-dormant (delq article gnus-newsgroup-dormant))
- (setq gnus-newsgroup-expirable (delq article gnus-newsgroup-expirable))
- (setq gnus-newsgroup-reads (delq article gnus-newsgroup-reads))
- (cond ((= mark gnus-ticked-mark)
- (push article gnus-newsgroup-marked))
- ((= mark gnus-dormant-mark)
- (push article gnus-newsgroup-dormant))
- (t
- (push article gnus-newsgroup-unreads)))
- (setq gnus-newsgroup-reads
- (delq (assq article gnus-newsgroup-reads)
- gnus-newsgroup-reads))
-
- ;; See whether the article is to be put in the cache.
- (and gnus-use-cache
- (vectorp (gnus-summary-article-header article))
- (save-excursion
- (gnus-cache-possibly-enter-article
- gnus-newsgroup-name article
- (gnus-summary-article-header article)
- (= mark gnus-ticked-mark)
- (= mark gnus-dormant-mark) (= mark gnus-unread-mark))))
-
- ;; Fix the mark.
- (gnus-summary-update-mark mark 'unread))
- t))
-
-(defun gnus-summary-mark-article (&optional article mark no-expire)
- "Mark ARTICLE with MARK. MARK can be any character.
-Four MARK strings are reserved: `? ' (unread), `?!' (ticked),
-`??' (dormant) and `?E' (expirable).
-If MARK is nil, then the default character `?D' is used.
-If ARTICLE is nil, then the article on the current line will be
-marked."
- ;; The mark might be a string.
- (and (stringp mark)
- (setq mark (aref mark 0)))
- ;; If no mark is given, then we check auto-expiring.
- (and (not no-expire)
- gnus-newsgroup-auto-expire
- (or (not mark)
- (and (numberp mark)
- (or (= mark gnus-killed-mark) (= mark gnus-del-mark)
- (= mark gnus-catchup-mark) (= mark gnus-low-score-mark)
- (= mark gnus-read-mark) (= mark gnus-souped-mark))))
- (setq mark gnus-expirable-mark))
- (let* ((mark (or mark gnus-del-mark))
- (article (or article (gnus-summary-article-number))))
- (or article (error "No article on current line"))
- (if (or (= mark gnus-unread-mark)
- (= mark gnus-ticked-mark)
- (= mark gnus-dormant-mark))
- (gnus-mark-article-as-unread article mark)
- (gnus-mark-article-as-read article mark))
-
- ;; See whether the article is to be put in the cache.
- (and gnus-use-cache
- (not (= mark gnus-canceled-mark))
- (vectorp (gnus-summary-article-header article))
- (save-excursion
- (gnus-cache-possibly-enter-article
- gnus-newsgroup-name article
- (gnus-summary-article-header article)
- (= mark gnus-ticked-mark)
- (= mark gnus-dormant-mark) (= mark gnus-unread-mark))))
-
- (if (gnus-summary-goto-subject article nil t)
- (let ((buffer-read-only nil))
- (gnus-summary-show-thread)
- ;; Fix the mark.
- (gnus-summary-update-mark mark 'unread)
- t))))
-
-(defun gnus-summary-update-secondary-mark (article)
- "Update the secondary (read, process, cache) mark."
- (gnus-summary-update-mark
- (cond ((memq article gnus-newsgroup-processable)
- gnus-process-mark)
- ((memq article gnus-newsgroup-cached)
- gnus-cached-mark)
- ((memq article gnus-newsgroup-replied)
- gnus-replied-mark)
- ((memq article gnus-newsgroup-saved)
- gnus-saved-mark)
- (t gnus-unread-mark))
- 'replied)
- (when (gnus-visual-p 'summary-highlight 'highlight)
- (run-hooks 'gnus-summary-update-hook))
- t)
-
-(defun gnus-summary-update-mark (mark type)
- (beginning-of-line)
- (let ((forward (cdr (assq type gnus-summary-mark-positions)))
- (buffer-read-only nil))
- (when (and forward
- (<= (+ forward (point)) (point-max)))
- ;; Go to the right position on the line.
- (goto-char (+ forward (point)))
- ;; Replace the old mark with the new mark.
- (subst-char-in-region (point) (1+ (point)) (following-char) mark)
- ;; Optionally update the marks by some user rule.
- (when (eq type 'unread)
- (gnus-data-set-mark
- (gnus-data-find (gnus-summary-article-number)) mark)
- (gnus-summary-update-line (eq mark gnus-unread-mark))))))
-
-(defun gnus-mark-article-as-read (article &optional mark)
- "Enter ARTICLE in the pertinent lists and remove it from others."
- ;; Make the article expirable.
- (let ((mark (or mark gnus-del-mark)))
- (if (= mark gnus-expirable-mark)
- (setq gnus-newsgroup-expirable (cons article gnus-newsgroup-expirable))
- (setq gnus-newsgroup-expirable (delq article gnus-newsgroup-expirable)))
- ;; Remove from unread and marked lists.
- (setq gnus-newsgroup-unreads (delq article gnus-newsgroup-unreads))
- (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked))
- (setq gnus-newsgroup-dormant (delq article gnus-newsgroup-dormant))
- (push (cons article mark) gnus-newsgroup-reads)
- ;; Possibly remove from cache, if that is used.
- (when gnus-use-cache
- (gnus-cache-enter-remove-article article))))
-
-(defun gnus-mark-article-as-unread (article &optional mark)
- "Enter ARTICLE in the pertinent lists and remove it from others."
- (let ((mark (or mark gnus-ticked-mark)))
- (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked))
- (setq gnus-newsgroup-dormant (delq article gnus-newsgroup-dormant))
- (setq gnus-newsgroup-expirable (delq article gnus-newsgroup-expirable))
- (setq gnus-newsgroup-unreads (delq article gnus-newsgroup-unreads))
- (cond ((= mark gnus-ticked-mark)
- (push article gnus-newsgroup-marked))
- ((= mark gnus-dormant-mark)
- (push article gnus-newsgroup-dormant))
- (t
- (push article gnus-newsgroup-unreads)))
- (setq gnus-newsgroup-reads
- (delq (assq article gnus-newsgroup-reads)
- gnus-newsgroup-reads))))
-
-(defalias 'gnus-summary-mark-as-unread-forward
- 'gnus-summary-tick-article-forward)
-(make-obsolete 'gnus-summary-mark-as-unread-forward
- 'gnus-summary-tick-article-forward)
-(defun gnus-summary-tick-article-forward (n)
- "Tick N articles forwards.
-If N is negative, tick backwards instead.
-The difference between N and the number of articles ticked is returned."
- (interactive "p")
- (gnus-summary-mark-forward n gnus-ticked-mark))
-
-(defalias 'gnus-summary-mark-as-unread-backward
- 'gnus-summary-tick-article-backward)
-(make-obsolete 'gnus-summary-mark-as-unread-backward
- 'gnus-summary-tick-article-backward)
-(defun gnus-summary-tick-article-backward (n)
- "Tick N articles backwards.
-The difference between N and the number of articles ticked is returned."
- (interactive "p")
- (gnus-summary-mark-forward (- n) gnus-ticked-mark))
-
-(defalias 'gnus-summary-mark-as-unread 'gnus-summary-tick-article)
-(make-obsolete 'gnus-summary-mark-as-unread 'gnus-summary-tick-article)
-(defun gnus-summary-tick-article (&optional article clear-mark)
- "Mark current article as unread.
-Optional 1st argument ARTICLE specifies article number to be marked as unread.
-Optional 2nd argument CLEAR-MARK remove any kinds of mark."
- (interactive)
- (gnus-summary-mark-article article (if clear-mark gnus-unread-mark
- gnus-ticked-mark)))
-
-(defun gnus-summary-mark-as-read-forward (n)
- "Mark N articles as read forwards.
-If N is negative, mark backwards instead.
-The difference between N and the actual number of articles marked is
-returned."
- (interactive "p")
- (gnus-summary-mark-forward n gnus-del-mark t))
-
-(defun gnus-summary-mark-as-read-backward (n)
- "Mark the N articles as read backwards.
-The difference between N and the actual number of articles marked is
-returned."
- (interactive "p")
- (gnus-summary-mark-forward (- n) gnus-del-mark t))
-
-(defun gnus-summary-mark-as-read (&optional article mark)
- "Mark current article as read.
-ARTICLE specifies the article to be marked as read.
-MARK specifies a string to be inserted at the beginning of the line."
- (gnus-summary-mark-article article mark))
-
-(defun gnus-summary-clear-mark-forward (n)
- "Clear marks from N articles forward.
-If N is negative, clear backward instead.
-The difference between N and the number of marks cleared is returned."
- (interactive "p")
- (gnus-summary-mark-forward n gnus-unread-mark))
-
-(defun gnus-summary-clear-mark-backward (n)
- "Clear marks from N articles backward.
-The difference between N and the number of marks cleared is returned."
- (interactive "p")
- (gnus-summary-mark-forward (- n) gnus-unread-mark))
-
-(defun gnus-summary-mark-unread-as-read ()
- "Intended to be used by `gnus-summary-mark-article-hook'."
- (when (memq gnus-current-article gnus-newsgroup-unreads)
- (gnus-summary-mark-article gnus-current-article gnus-read-mark)))
-
-(defun gnus-summary-mark-read-and-unread-as-read ()
- "Intended to be used by `gnus-summary-mark-article-hook'."
- (let ((mark (gnus-summary-article-mark)))
- (when (or (gnus-unread-mark-p mark)
- (gnus-read-mark-p mark))
- (gnus-summary-mark-article gnus-current-article gnus-read-mark))))
-
-(defun gnus-summary-mark-region-as-read (point mark all)
- "Mark all unread articles between point and mark as read.
-If given a prefix, mark all articles between point and mark as read,
-even ticked and dormant ones."
- (interactive "r\nP")
- (save-excursion
- (let (article)
- (goto-char point)
- (beginning-of-line)
- (while (and
- (< (point) mark)
- (progn
- (when (or all
- (memq (setq article (gnus-summary-article-number))
- gnus-newsgroup-unreads))
- (gnus-summary-mark-article article gnus-del-mark))
- t)
- (gnus-summary-find-next))))))
-
-(defun gnus-summary-mark-below (score mark)
- "Mark articles with score less than SCORE with MARK."
- (interactive "P\ncMark: ")
- (gnus-set-global-variables)
- (setq score (if score
- (prefix-numeric-value score)
- (or gnus-summary-default-score 0)))
- (save-excursion
- (set-buffer gnus-summary-buffer)
- (goto-char (point-min))
- (while
- (progn
- (and (< (gnus-summary-article-score) score)
- (gnus-summary-mark-article nil mark))
- (gnus-summary-find-next)))))
-
-(defun gnus-summary-kill-below (&optional score)
- "Mark articles with score below SCORE as read."
- (interactive "P")
- (gnus-set-global-variables)
- (gnus-summary-mark-below score gnus-killed-mark))
-
-(defun gnus-summary-clear-above (&optional score)
- "Clear all marks from articles with score above SCORE."
- (interactive "P")
- (gnus-set-global-variables)
- (gnus-summary-mark-above score gnus-unread-mark))
-
-(defun gnus-summary-tick-above (&optional score)
- "Tick all articles with score above SCORE."
- (interactive "P")
- (gnus-set-global-variables)
- (gnus-summary-mark-above score gnus-ticked-mark))
-
-(defun gnus-summary-mark-above (score mark)
- "Mark articles with score over SCORE with MARK."
- (interactive "P\ncMark: ")
- (gnus-set-global-variables)
- (setq score (if score
- (prefix-numeric-value score)
- (or gnus-summary-default-score 0)))
- (save-excursion
- (set-buffer gnus-summary-buffer)
- (goto-char (point-min))
- (while (and (progn
- (if (> (gnus-summary-article-score) score)
- (gnus-summary-mark-article nil mark))
- t)
- (gnus-summary-find-next)))))
-
-;; Suggested by Daniel Quinlan <quinlan@best.com>.
-(defalias 'gnus-summary-show-all-expunged 'gnus-summary-limit-include-expunged)
-(defun gnus-summary-limit-include-expunged (&optional no-error)
- "Display all the hidden articles that were expunged for low scores."
- (interactive)
- (gnus-set-global-variables)
- (let ((buffer-read-only nil))
- (let ((scored gnus-newsgroup-scored)
- headers h)
- (while scored
- (or (gnus-summary-goto-subject (caar scored))
- (and (setq h (gnus-summary-article-header (caar scored)))
- (< (cdar scored) gnus-summary-expunge-below)
- (setq headers (cons h headers))))
- (setq scored (cdr scored)))
- (if (not headers)
- (when (not no-error)
- (error "No expunged articles hidden."))
- (goto-char (point-min))
- (gnus-summary-prepare-unthreaded (nreverse headers))
- (goto-char (point-min))
- (gnus-summary-position-point)
- t))))
-
-(defun gnus-summary-catchup (&optional all quietly to-here not-mark)
- "Mark all articles not marked as unread in this newsgroup as read.
-If prefix argument ALL is non-nil, all articles are marked as read.
-If QUIETLY is non-nil, no questions will be asked.
-If TO-HERE is non-nil, it should be a point in the buffer. All
-articles before this point will be marked as read.
-The number of articles marked as read is returned."
- (interactive "P")
- (gnus-set-global-variables)
- (prog1
- (if (or quietly
- (not gnus-interactive-catchup) ;Without confirmation?
- gnus-expert-user
- (gnus-y-or-n-p
- (if all
- "Mark absolutely all articles as read? "
- "Mark all unread articles as read? ")))
- (if (and not-mark
- (not gnus-newsgroup-adaptive)
- (not gnus-newsgroup-auto-expire))
- (progn
- (when all
- (setq gnus-newsgroup-marked nil
- gnus-newsgroup-dormant nil))
- (setq gnus-newsgroup-unreads nil))
- ;; We actually mark all articles as canceled, which we
- ;; have to do when using auto-expiry or adaptive scoring.
- (gnus-summary-show-all-threads)
- (if (gnus-summary-first-subject (not all))
- (while (and
- (if to-here (< (point) to-here) t)
- (gnus-summary-mark-article-as-read gnus-catchup-mark)
- (gnus-summary-find-next (not all)))))
- (unless to-here
- (setq gnus-newsgroup-unreads nil))
- (gnus-set-mode-line 'summary)))
- (let ((method (gnus-find-method-for-group gnus-newsgroup-name)))
- (if (and (not to-here) (eq 'nnvirtual (car method)))
- (nnvirtual-catchup-group
- (gnus-group-real-name gnus-newsgroup-name) (nth 1 method) all)))
- (gnus-summary-position-point)))
-
-(defun gnus-summary-catchup-to-here (&optional all)
- "Mark all unticked articles before the current one as read.
-If ALL is non-nil, also mark ticked and dormant articles as read."
- (interactive "P")
- (gnus-set-global-variables)
- (save-excursion
- (gnus-save-hidden-threads
- (let ((beg (point)))
- ;; We check that there are unread articles.
- (when (or all (gnus-summary-find-prev))
- (gnus-summary-catchup all t beg)))))
- (gnus-summary-position-point))
-
-(defun gnus-summary-catchup-all (&optional quietly)
- "Mark all articles in this newsgroup as read."
- (interactive "P")
- (gnus-set-global-variables)
- (gnus-summary-catchup t quietly))
-
-(defun gnus-summary-catchup-and-exit (&optional all quietly)
- "Mark all articles not marked as unread in this newsgroup as read, then exit.
-If prefix argument ALL is non-nil, all articles are marked as read."
- (interactive "P")
- (gnus-set-global-variables)
- (gnus-summary-catchup all quietly nil 'fast)
- ;; Select next newsgroup or exit.
- (if (eq gnus-auto-select-next 'quietly)
- (gnus-summary-next-group nil)
- (gnus-summary-exit)))
-
-(defun gnus-summary-catchup-all-and-exit (&optional quietly)
- "Mark all articles in this newsgroup as read, and then exit."
- (interactive "P")
- (gnus-set-global-variables)
- (gnus-summary-catchup-and-exit t quietly))
-
-;; Suggested by "Arne Eofsson" <arne@hodgkin.mbi.ucla.edu>.
-(defun gnus-summary-catchup-and-goto-next-group (&optional all)
- "Mark all articles in this group as read and select the next group.
-If given a prefix, mark all articles, unread as well as ticked, as
-read."
- (interactive "P")
- (gnus-set-global-variables)
- (save-excursion
- (gnus-summary-catchup all))
- (gnus-summary-next-article t nil nil t))
-
-;; Thread-based commands.
-
-(defun gnus-summary-articles-in-thread (&optional article)
- "Return a list of all articles in the current thread.
-If ARTICLE is non-nil, return all articles in the thread that starts
-with that article."
- (let* ((article (or article (gnus-summary-article-number)))
- (data (gnus-data-find-list article))
- (top-level (gnus-data-level (car data)))
- (top-subject
- (cond ((null gnus-thread-operation-ignore-subject)
- (gnus-simplify-subject-re
- (mail-header-subject (gnus-data-header (car data)))))
- ((eq gnus-thread-operation-ignore-subject 'fuzzy)
- (gnus-simplify-subject-fuzzy
- (mail-header-subject (gnus-data-header (car data)))))
- (t nil)))
- (end-point (save-excursion
- (if (gnus-summary-go-to-next-thread)
- (point) (point-max))))
- articles)
- (while (and data
- (< (gnus-data-pos (car data)) end-point))
- (when (or (not top-subject)
- (string= top-subject
- (if (eq gnus-thread-operation-ignore-subject 'fuzzy)
- (gnus-simplify-subject-fuzzy
- (mail-header-subject
- (gnus-data-header (car data))))
- (gnus-simplify-subject-re
- (mail-header-subject
- (gnus-data-header (car data)))))))
- (push (gnus-data-number (car data)) articles))
- (unless (and (setq data (cdr data))
- (> (gnus-data-level (car data)) top-level))
- (setq data nil)))
- ;; Return the list of articles.
- (nreverse articles)))
-
-(defun gnus-summary-rethread-current ()
- "Rethread the thread the current article is part of."
- (interactive)
- (gnus-set-global-variables)
- (let* ((gnus-show-threads t)
- (article (gnus-summary-article-number))
- (id (mail-header-id (gnus-summary-article-header)))
- (gnus-newsgroup-threads (list (gnus-id-to-thread (gnus-root-id id)))))
- (unless id
- (error "No article on the current line"))
- (gnus-rebuild-thread id)
- (gnus-summary-goto-subject article)))
-
-(defun gnus-summary-reparent-thread ()
- "Make current article child of the marked (or previous) article.
-
-Note that the re-threading will only work if `gnus-thread-ignore-subject'
-is non-nil or the Subject: of both articles are the same."
- (interactive)
- (or (not (gnus-group-read-only-p))
- (error "The current newsgroup does not support article editing."))
- (or (<= (length gnus-newsgroup-processable) 1)
- (error "No more than one article may be marked."))
- (save-window-excursion
- (let ((gnus-article-buffer " *reparent*")
- (current-article (gnus-summary-article-number))
- ; first grab the marked article, otherwise one line up.
- (parent-article (if (not (null gnus-newsgroup-processable))
- (car gnus-newsgroup-processable)
- (save-excursion
- (if (eq (forward-line -1) 0)
- (gnus-summary-article-number)
- (error "Beginning of summary buffer."))))))
- (or (not (eq current-article parent-article))
- (error "An article may not be self-referential."))
- (let ((message-id (mail-header-id
- (gnus-summary-article-header parent-article))))
- (or (and message-id (not (equal message-id "")))
- (error "No message-id in desired parent."))
- (gnus-summary-select-article t t nil current-article)
- (set-buffer gnus-article-buffer)
- (setq buffer-read-only nil)
- (let ((buf (format "%s" (buffer-string))))
- (erase-buffer)
- (insert buf))
- (goto-char (point-min))
- (if (search-forward-regexp "^References: " nil t)
- (insert message-id " " )
- (insert "References: " message-id "\n"))
- (or (gnus-request-replace-article current-article
- (car gnus-article-current)
- gnus-article-buffer)
- (error "Couldn't replace article."))
- (set-buffer gnus-summary-buffer)
- (gnus-summary-unmark-all-processable)
- (gnus-summary-rethread-current)
- (gnus-message 3 "Article %d is now the child of article %d."
- current-article parent-article)))))
-
-(defun gnus-summary-toggle-threads (&optional arg)
- "Toggle showing conversation threads.
-If ARG is positive number, turn showing conversation threads on."
- (interactive "P")
- (gnus-set-global-variables)
- (let ((current (or (gnus-summary-article-number) gnus-newsgroup-end)))
- (setq gnus-show-threads
- (if (null arg) (not gnus-show-threads)
- (> (prefix-numeric-value arg) 0)))
- (gnus-summary-prepare)
- (gnus-summary-goto-subject current)
- (gnus-message 6 "Threading is now %s" (if gnus-show-threads "on" "off"))
- (gnus-summary-position-point)))
-
-(defun gnus-summary-show-all-threads ()
- "Show all threads."
- (interactive)
- (gnus-set-global-variables)
- (save-excursion
- (let ((buffer-read-only nil))
- (subst-char-in-region (point-min) (point-max) ?\^M ?\n t)))
- (gnus-summary-position-point))
-
-(defun gnus-summary-show-thread ()
- "Show thread subtrees.
-Returns nil if no thread was there to be shown."
- (interactive)
- (gnus-set-global-variables)
- (let ((buffer-read-only nil)
- (orig (point))
- ;; first goto end then to beg, to have point at beg after let
- (end (progn (end-of-line) (point)))
- (beg (progn (beginning-of-line) (point))))
- (prog1
- ;; Any hidden lines here?
- (search-forward "\r" end t)
- (subst-char-in-region beg end ?\^M ?\n t)
- (goto-char orig)
- (gnus-summary-position-point))))
-
-(defun gnus-summary-hide-all-threads ()
- "Hide all thread subtrees."
- (interactive)
- (gnus-set-global-variables)
- (save-excursion
- (goto-char (point-min))
- (gnus-summary-hide-thread)
- (while (zerop (gnus-summary-next-thread 1 t))
- (gnus-summary-hide-thread)))
- (gnus-summary-position-point))
-
-(defun gnus-summary-hide-thread ()
- "Hide thread subtrees.
-Returns nil if no threads were there to be hidden."
- (interactive)
- (gnus-set-global-variables)
- (let ((buffer-read-only nil)
- (start (point))
- (article (gnus-summary-article-number)))
- (goto-char start)
- ;; Go forward until either the buffer ends or the subthread
- ;; ends.
- (when (and (not (eobp))
- (or (zerop (gnus-summary-next-thread 1 t))
- (goto-char (point-max))))
- (prog1
- (if (and (> (point) start)
- (search-backward "\n" start t))
- (progn
- (subst-char-in-region start (point) ?\n ?\^M)
- (gnus-summary-goto-subject article))
- (goto-char start)
- nil)
- ;;(gnus-summary-position-point)
- ))))
-
-(defun gnus-summary-go-to-next-thread (&optional previous)
- "Go to the same level (or less) next thread.
-If PREVIOUS is non-nil, go to previous thread instead.
-Return the article number moved to, or nil if moving was impossible."
- (let ((level (gnus-summary-thread-level))
- (way (if previous -1 1))
- (beg (point)))
- (forward-line way)
- (while (and (not (eobp))
- (< level (gnus-summary-thread-level)))
- (forward-line way))
- (if (eobp)
- (progn
- (goto-char beg)
- nil)
- (setq beg (point))
- (prog1
- (gnus-summary-article-number)
- (goto-char beg)))))
-
-(defun gnus-summary-go-to-next-thread-old (&optional previous)
- "Go to the same level (or less) next thread.
-If PREVIOUS is non-nil, go to previous thread instead.
-Return the article number moved to, or nil if moving was impossible."
- (if (and (eq gnus-summary-make-false-root 'dummy)
- (gnus-summary-article-intangible-p))
- (let ((beg (point)))
- (while (and (zerop (forward-line 1))
- (not (gnus-summary-article-intangible-p))
- (not (zerop (save-excursion
- (gnus-summary-thread-level))))))
- (if (eobp)
- (progn
- (goto-char beg)
- nil)
- (point)))
- (let* ((level (gnus-summary-thread-level))
- (article (gnus-summary-article-number))
- (data (cdr (gnus-data-find-list article (gnus-data-list previous))))
- oart)
- (while data
- (if (<= (gnus-data-level (car data)) level)
- (setq oart (gnus-data-number (car data))
- data nil)
- (setq data (cdr data))))
- (and oart
- (gnus-summary-goto-subject oart)))))
-
-(defun gnus-summary-next-thread (n &optional silent)
- "Go to the same level next N'th thread.
-If N is negative, search backward instead.
-Returns the difference between N and the number of skips actually
-done.
-
-If SILENT, don't output messages."
- (interactive "p")
- (gnus-set-global-variables)
- (let ((backward (< n 0))
- (n (abs n))
- old dum int)
- (while (and (> n 0)
- (gnus-summary-go-to-next-thread backward))
- (decf n))
- (unless silent
- (gnus-summary-position-point))
- (when (and (not silent) (/= 0 n))
- (gnus-message 7 "No more threads"))
- n))
-
-(defun gnus-summary-prev-thread (n)
- "Go to the same level previous N'th thread.
-Returns the difference between N and the number of skips actually
-done."
- (interactive "p")
- (gnus-set-global-variables)
- (gnus-summary-next-thread (- n)))
-
-(defun gnus-summary-go-down-thread ()
- "Go down one level in the current thread."
- (let ((children (gnus-summary-article-children)))
- (and children
- (gnus-summary-goto-subject (car children)))))
-
-(defun gnus-summary-go-up-thread ()
- "Go up one level in the current thread."
- (let ((parent (gnus-summary-article-parent)))
- (and parent
- (gnus-summary-goto-subject parent))))
-
-(defun gnus-summary-down-thread (n)
- "Go down thread N steps.
-If N is negative, go up instead.
-Returns the difference between N and how many steps down that were
-taken."
- (interactive "p")
- (gnus-set-global-variables)
- (let ((up (< n 0))
- (n (abs n)))
- (while (and (> n 0)
- (if up (gnus-summary-go-up-thread)
- (gnus-summary-go-down-thread)))
- (setq n (1- n)))
- (gnus-summary-position-point)
- (if (/= 0 n) (gnus-message 7 "Can't go further"))
- n))
-
-(defun gnus-summary-up-thread (n)
- "Go up thread N steps.
-If N is negative, go up instead.
-Returns the difference between N and how many steps down that were
-taken."
- (interactive "p")
- (gnus-set-global-variables)
- (gnus-summary-down-thread (- n)))
-
-(defun gnus-summary-top-thread ()
- "Go to the top of the thread."
- (interactive)
- (gnus-set-global-variables)
- (while (gnus-summary-go-up-thread))
- (gnus-summary-article-number))
-
-(defun gnus-summary-kill-thread (&optional unmark)
- "Mark articles under current thread as read.
-If the prefix argument is positive, remove any kinds of marks.
-If the prefix argument is negative, tick articles instead."
- (interactive "P")
- (gnus-set-global-variables)
- (when unmark
- (setq unmark (prefix-numeric-value unmark)))
- (let ((articles (gnus-summary-articles-in-thread)))
- (save-excursion
- ;; Expand the thread.
- (gnus-summary-show-thread)
- ;; Mark all the articles.
- (while articles
- (gnus-summary-goto-subject (car articles))
- (cond ((null unmark)
- (gnus-summary-mark-article-as-read gnus-killed-mark))
- ((> unmark 0)
- (gnus-summary-mark-article-as-unread gnus-unread-mark))
- (t
- (gnus-summary-mark-article-as-unread gnus-ticked-mark)))
- (setq articles (cdr articles))))
- ;; Hide killed subtrees.
- (and (null unmark)
- gnus-thread-hide-killed
- (gnus-summary-hide-thread))
- ;; If marked as read, go to next unread subject.
- (if (null unmark)
- ;; Go to next unread subject.
- (gnus-summary-next-subject 1 t)))
- (gnus-set-mode-line 'summary))
-
-;; Summary sorting commands
-
-(defun gnus-summary-sort-by-number (&optional reverse)
- "Sort summary buffer by article number.
-Argument REVERSE means reverse order."
- (interactive "P")
- (gnus-summary-sort 'number reverse))
-
-(defun gnus-summary-sort-by-author (&optional reverse)
- "Sort summary buffer by author name alphabetically.
-If case-fold-search is non-nil, case of letters is ignored.
-Argument REVERSE means reverse order."
- (interactive "P")
- (gnus-summary-sort 'author reverse))
-
-(defun gnus-summary-sort-by-subject (&optional reverse)
- "Sort summary buffer by subject alphabetically. `Re:'s are ignored.
-If case-fold-search is non-nil, case of letters is ignored.
-Argument REVERSE means reverse order."
- (interactive "P")
- (gnus-summary-sort 'subject reverse))
-
-(defun gnus-summary-sort-by-date (&optional reverse)
- "Sort summary buffer by date.
-Argument REVERSE means reverse order."
- (interactive "P")
- (gnus-summary-sort 'date reverse))
-
-(defun gnus-summary-sort-by-score (&optional reverse)
- "Sort summary buffer by score.
-Argument REVERSE means reverse order."
- (interactive "P")
- (gnus-summary-sort 'score reverse))
-
-(defun gnus-summary-sort (predicate reverse)
- "Sort summary buffer by PREDICATE. REVERSE means reverse order."
- (gnus-set-global-variables)
- (let* ((thread (intern (format "gnus-thread-sort-by-%s" predicate)))
- (article (intern (format "gnus-article-sort-by-%s" predicate)))
- (gnus-thread-sort-functions
- (list
- (if (not reverse)
- thread
- `(lambda (t1 t2)
- (,thread t2 t1)))))
- (gnus-article-sort-functions
- (list
- (if (not reverse)
- article
- `(lambda (t1 t2)
- (,article t2 t1)))))
- (buffer-read-only)
- (gnus-summary-prepare-hook nil))
- ;; We do the sorting by regenerating the threads.
- (gnus-summary-prepare)
- ;; Hide subthreads if needed.
- (when (and gnus-show-threads gnus-thread-hide-subtree)
- (gnus-summary-hide-all-threads)))
- ;; If in async mode, we send some info to the backend.
- (when gnus-newsgroup-async
- (gnus-request-asynchronous
- gnus-newsgroup-name gnus-newsgroup-data)))
-
-(defun gnus-sortable-date (date)
- "Make sortable string by string-lessp from DATE.
-Timezone package is used."
- (condition-case ()
- (progn
- (setq date (inline (timezone-fix-time
- date nil
- (aref (inline (timezone-parse-date date)) 4))))
- (inline
- (timezone-make-sortable-date
- (aref date 0) (aref date 1) (aref date 2)
- (inline
- (timezone-make-time-string
- (aref date 3) (aref date 4) (aref date 5))))))
- (error "")))
-
-;; Summary saving commands.
-
-(defun gnus-summary-save-article (&optional n not-saved)
- "Save the current article using the default saver function.
-If N is a positive number, save the N next articles.
-If N is a negative number, save the N previous articles.
-If N is nil and any articles have been marked with the process mark,
-save those articles instead.
-The variable `gnus-default-article-saver' specifies the saver function."
- (interactive "P")
- (gnus-set-global-variables)
- (let ((articles (gnus-summary-work-articles n))
- (save-buffer (save-excursion
- (nnheader-set-temp-buffer " *Gnus Save*")))
- file header article)
- (while articles
- (setq header (gnus-summary-article-header
- (setq article (pop articles))))
- (if (not (vectorp header))
- ;; This is a pseudo-article.
- (if (assq 'name header)
- (gnus-copy-file (cdr (assq 'name header)))
- (gnus-message 1 "Article %d is unsaveable" article))
- ;; This is a real article.
- (save-window-excursion
- (gnus-summary-select-article t nil nil article))
- (save-excursion
- (set-buffer save-buffer)
- (erase-buffer)
- (insert-buffer-substring gnus-original-article-buffer))
- (unless gnus-save-all-headers
- ;; Remove headers accoring to `gnus-saved-headers'.
- (let ((gnus-visible-headers
- (or gnus-saved-headers gnus-visible-headers))
- (gnus-article-buffer save-buffer))
- (gnus-article-hide-headers 1 t)))
- (save-window-excursion
- (if (not gnus-default-article-saver)
- (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.
- (set-buffer gnus-article-buffer)
- (let ((gnus-original-article-buffer save-buffer))
- (set-buffer gnus-summary-buffer)
- (setq file (funcall
- gnus-default-article-saver
- (cond
- ((not gnus-prompt-before-saving)
- 'default)
- ((eq gnus-prompt-before-saving 'always)
- nil)
- (t file)))))))
- (gnus-summary-remove-process-mark article)
- (unless not-saved
- (gnus-summary-set-saved-mark article))))
- (gnus-kill-buffer save-buffer)
- (gnus-summary-position-point)
- n))
-
-(defun gnus-summary-pipe-output (&optional arg)
- "Pipe the current article to a subprocess.
-If N is a positive number, pipe the N next articles.
-If N is a negative number, pipe the N previous articles.
-If N is nil and any articles have been marked with the process mark,
-pipe those articles instead."
- (interactive "P")
- (gnus-set-global-variables)
- (let ((gnus-default-article-saver 'gnus-summary-save-in-pipe))
- (gnus-summary-save-article arg t))
- (gnus-configure-windows 'pipe))
-
-(defun gnus-summary-save-article-mail (&optional arg)
- "Append the current article to an mail file.
-If N is a positive number, save the N next articles.
-If N is a negative number, save the N previous articles.
-If N is nil and any articles have been marked with the process mark,
-save those articles instead."
- (interactive "P")
- (gnus-set-global-variables)
- (let ((gnus-default-article-saver 'gnus-summary-save-in-mail))
- (gnus-summary-save-article arg)))
-
-(defun gnus-summary-save-article-rmail (&optional arg)
- "Append the current article to an rmail file.
-If N is a positive number, save the N next articles.
-If N is a negative number, save the N previous articles.
-If N is nil and any articles have been marked with the process mark,
-save those articles instead."
- (interactive "P")
- (gnus-set-global-variables)
- (let ((gnus-default-article-saver 'gnus-summary-save-in-rmail))
- (gnus-summary-save-article arg)))
-
-(defun gnus-summary-save-article-file (&optional arg)
- "Append the current article to a file.
-If N is a positive number, save the N next articles.
-If N is a negative number, save the N previous articles.
-If N is nil and any articles have been marked with the process mark,
-save those articles instead."
- (interactive "P")
- (gnus-set-global-variables)
- (let ((gnus-default-article-saver 'gnus-summary-save-in-file))
- (gnus-summary-save-article arg)))
-
-(defun gnus-summary-save-article-body-file (&optional arg)
- "Append the current article body to a file.
-If N is a positive number, save the N next articles.
-If N is a negative number, save the N previous articles.
-If N is nil and any articles have been marked with the process mark,
-save those articles instead."
- (interactive "P")
- (gnus-set-global-variables)
- (let ((gnus-default-article-saver 'gnus-summary-save-body-in-file))
- (gnus-summary-save-article arg)))
-
-(defun gnus-get-split-value (methods)
- "Return a value based on the split METHODS."
- (let (split-name method result match)
- (when methods
- (save-excursion
- (set-buffer gnus-original-article-buffer)
- (save-restriction
- (nnheader-narrow-to-headers)
- (while methods
- (goto-char (point-min))
- (setq method (pop methods))
- (setq match (car method))
- (when (cond
- ((stringp match)
- ;; Regular expression.
- (condition-case ()
- (re-search-forward match nil t)
- (error nil)))
- ((gnus-functionp match)
- ;; Function.
- (save-restriction
- (widen)
- (setq result (funcall match gnus-newsgroup-name))))
- ((consp match)
- ;; Form.
- (save-restriction
- (widen)
- (setq result (eval match)))))
- (setq split-name (append (cdr method) split-name))
- (cond ((stringp result)
- (push result split-name))
- ((consp result)
- (setq split-name (append result split-name)))))))))
- split-name))
-
-(defun gnus-read-move-group-name (prompt default articles prefix)
- "Read a group name."
- (let* ((split-name (gnus-get-split-value gnus-move-split-methods))
- (minibuffer-confirm-incomplete nil) ; XEmacs
- group-map
- (dum (mapatoms
- (lambda (g)
- (and (boundp g)
- (symbol-name g)
- (memq 'respool
- (assoc (symbol-name
- (car (gnus-find-method-for-group
- (symbol-name g))))
- gnus-valid-select-methods))
- (push (list (symbol-name g)) group-map)))
- gnus-active-hashtb))
- (prom
- (format "%s %s to:"
- prompt
- (if (> (length articles) 1)
- (format "these %d articles" (length articles))
- "this article")))
- (to-newsgroup
- (cond
- ((null split-name)
- (gnus-completing-read default prom
- group-map nil nil prefix
- 'gnus-group-history))
- ((= 1 (length split-name))
- (gnus-completing-read (car split-name) prom group-map
- nil nil nil
- 'gnus-group-history))
- (t
- (gnus-completing-read nil prom
- (mapcar (lambda (el) (list el))
- (nreverse split-name))
- nil nil nil
- 'gnus-group-history)))))
- (when to-newsgroup
- (if (or (string= to-newsgroup "")
- (string= to-newsgroup prefix))
- (setq to-newsgroup (or default "")))
- (or (gnus-active to-newsgroup)
- (gnus-activate-group to-newsgroup)
- (if (gnus-y-or-n-p (format "No such group: %s. Create it? "
- to-newsgroup))
- (or (and (gnus-request-create-group
- to-newsgroup (gnus-group-name-to-method to-newsgroup))
- (gnus-activate-group to-newsgroup nil nil
- (gnus-group-name-to-method
- to-newsgroup)))
- (error "Couldn't create group %s" to-newsgroup)))
- (error "No such group: %s" to-newsgroup)))
- to-newsgroup))
-
-(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)))))))
- ;; 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 charaters.
- (nnheader-translate-file-chars file)))
-
-(defun gnus-article-archive-name (group)
- "Return the first instance of an \"Archive-name\" in the current buffer."
- (let ((case-fold-search t))
- (when (re-search-forward "archive-name: *\\([^ \n\t]+\\)[ \t]*$" nil t)
- (match-string 1))))
-
-(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
- (cond ((eq filename 'default)
- default-name)
- (filename filename)
- (t (gnus-read-save-file-name
- "Save in rmail file:" default-name))))
- (gnus-make-directory (file-name-directory filename))
- (gnus-eval-in-buffer-window gnus-original-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)))
-
-(defun gnus-summary-save-in-mail (&optional filename)
- "Append this article to Unix mail 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-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
- (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-original-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)))
-
-(defun gnus-summary-save-in-file (&optional filename)
- "Append this article to 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-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))))
- (gnus-make-directory (file-name-directory filename))
- (gnus-eval-in-buffer-window gnus-original-article-buffer
- (save-excursion
- (save-restriction
- (widen)
- (gnus-output-to-file filename))))
- ;; Remember the directory name to save articles.
- (setq gnus-newsgroup-last-file filename)))
-
-(defun gnus-summary-save-body-in-file (&optional filename)
- "Append this article body to a file.
-Optional argument FILENAME specifies file name.
-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
- (cond ((eq filename 'default)
- default-name)
- (filename filename)
- (t (gnus-read-save-file-name
- "Save body in file:" default-name))))
- (gnus-make-directory (file-name-directory filename))
- (gnus-eval-in-buffer-window gnus-original-article-buffer
- (save-excursion
- (save-restriction
- (widen)
- (goto-char (point-min))
- (and (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)))
-
-(defun gnus-summary-save-in-pipe (&optional command)
- "Pipe this article to subprocess."
- (interactive)
- (gnus-set-global-variables)
- (setq command
- (cond ((eq command 'default)
- gnus-last-shell-command)
- (command command)
- (t (read-string "Shell command on article: "
- gnus-last-shell-command))))
- (if (string-equal command "")
- (setq command gnus-last-shell-command))
- (gnus-eval-in-buffer-window gnus-article-buffer
- (save-restriction
- (widen)
- (shell-command-on-region (point-min) (point-max) command nil)))
- (setq gnus-last-shell-command command))
-
-;; Summary extract commands
-
-(defun gnus-summary-insert-pseudos (pslist &optional not-view)
- (let ((buffer-read-only nil)
- (article (gnus-summary-article-number))
- after-article b e)
- (or (gnus-summary-goto-subject article)
- (error (format "No such article: %d" article)))
- (gnus-summary-position-point)
- ;; If all commands are to be bunched up on one line, we collect
- ;; them here.
- (if gnus-view-pseudos-separately
- ()
- (let ((ps (setq pslist (sort pslist 'gnus-pseudos<)))
- files action)
- (while ps
- (setq action (cdr (assq 'action (car ps))))
- (setq files (list (cdr (assq 'name (car ps)))))
- (while (and ps (cdr ps)
- (string= (or action "1")
- (or (cdr (assq 'action (cadr ps))) "2")))
- (setq files (cons (cdr (assq 'name (cadr ps))) files))
- (setcdr ps (cddr ps)))
- (if (not files)
- ()
- (if (not (string-match "%s" action))
- (setq files (cons " " files)))
- (setq files (cons " " files))
- (and (assq 'execute (car ps))
- (setcdr (assq 'execute (car ps))
- (funcall (if (string-match "%s" action)
- 'format 'concat)
- action
- (mapconcat (lambda (f) f) files " ")))))
- (setq ps (cdr ps)))))
- (if (and gnus-view-pseudos (not not-view))
- (while pslist
- (and (assq 'execute (car pslist))
- (gnus-execute-command (cdr (assq 'execute (car pslist)))
- (eq gnus-view-pseudos 'not-confirm)))
- (setq pslist (cdr pslist)))
- (save-excursion
- (while pslist
- (setq after-article (or (cdr (assq 'article (car pslist)))
- (gnus-summary-article-number)))
- (gnus-summary-goto-subject after-article)
- (forward-line 1)
- (setq b (point))
- (insert " " (file-name-nondirectory
- (cdr (assq 'name (car pslist))))
- ": " (or (cdr (assq 'execute (car pslist))) "") "\n")
- (setq e (point))
- (forward-line -1) ; back to `b'
- (gnus-add-text-properties
- b (1- e) (list 'gnus-number gnus-reffed-article-number
- gnus-mouse-face-prop gnus-mouse-face))
- (gnus-data-enter
- after-article gnus-reffed-article-number
- gnus-unread-mark b (car pslist) 0 (- e b))
- (push gnus-reffed-article-number gnus-newsgroup-unreads)
- (setq gnus-reffed-article-number (1- gnus-reffed-article-number))
- (setq pslist (cdr pslist)))))))
-
-(defun gnus-pseudos< (p1 p2)
- (let ((c1 (cdr (assq 'action p1)))
- (c2 (cdr (assq 'action p2))))
- (and c1 c2 (string< c1 c2))))
-
-(defun gnus-request-pseudo-article (props)
- (cond ((assq 'execute props)
- (gnus-execute-command (cdr (assq 'execute props)))))
- (let ((gnus-current-article (gnus-summary-article-number)))
- (run-hooks 'gnus-mark-article-hook)))
-
-(defun gnus-execute-command (command &optional automatic)
- (save-excursion
- (gnus-article-setup-buffer)
- (set-buffer gnus-article-buffer)
- (setq buffer-read-only nil)
- (let ((command (if automatic command (read-string "Command: " command)))
- ;; Just binding this here doesn't help, because there might
- ;; be output from the process after exiting the scope of
- ;; this `let'.
- ;; (buffer-read-only nil)
- )
- (erase-buffer)
- (insert "$ " command "\n\n")
- (if gnus-view-pseudo-asynchronously
- (start-process "gnus-execute" nil shell-file-name
- shell-command-switch command)
- (call-process shell-file-name nil t nil
- shell-command-switch command)))))
-
-(defun gnus-copy-file (file &optional to)
- "Copy FILE to TO."
- (interactive
- (list (read-file-name "Copy file: " default-directory)
- (read-file-name "Copy file to: " default-directory)))
- (gnus-set-global-variables)
- (or to (setq to (read-file-name "Copy file to: " default-directory)))
- (and (file-directory-p to)
- (setq to (concat (file-name-as-directory to)
- (file-name-nondirectory file))))
- (copy-file file to))
-
-;; Summary kill commands.
-
-(defun gnus-summary-edit-global-kill (article)
- "Edit the \"global\" kill file."
- (interactive (list (gnus-summary-article-number)))
- (gnus-set-global-variables)
- (gnus-group-edit-global-kill article))
-
-(defun gnus-summary-edit-local-kill ()
- "Edit a local kill file applied to the current newsgroup."
- (interactive)
- (gnus-set-global-variables)
- (setq gnus-current-headers (gnus-summary-article-header))
- (gnus-set-global-variables)
- (gnus-group-edit-local-kill
- (gnus-summary-article-number) gnus-newsgroup-name))
-
-\f
-;;;
-;;; Gnus article mode
-;;;
-
-(put 'gnus-article-mode 'mode-class 'special)
-
-(if gnus-article-mode-map
- nil
- (setq gnus-article-mode-map (make-keymap))
- (suppress-keymap 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
- "<" beginning-of-buffer
- ">" end-of-buffer
- "\C-c\C-i" gnus-info-find-node
- "\C-c\C-b" gnus-bug)
-
- (substitute-key-definition
- 'undefined 'gnus-article-read-summary-keys gnus-article-mode-map))
-
-(defun gnus-article-mode ()
- "Major mode for displaying an article.
-
-All normal editing commands are switched off.
-
-The following commands are available:
-
-\\<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
-\\[gnus-article-refer-article]\t Go to the article referred to by an article id near point
-\\[gnus-article-show-summary]\t Display the summary buffer
-\\[gnus-article-mail]\t Send a reply to the address near point
-\\[gnus-article-describe-briefly]\t Describe the current mode briefly
-\\[gnus-info-find-node]\t Go to the Gnus info node"
- (interactive)
- (when (and menu-bar-mode
- (gnus-visual-p 'article-menu 'menu))
- (gnus-article-make-menu-bar))
- (kill-all-local-variables)
- (gnus-simplify-mode-line)
- (setq mode-name "Article")
- (setq major-mode 'gnus-article-mode)
- (make-local-variable 'minor-mode-alist)
- (or (assq 'gnus-show-mime minor-mode-alist)
- (setq minor-mode-alist
- (cons (list 'gnus-show-mime " MIME") minor-mode-alist)))
- (use-local-map gnus-article-mode-map)
- (make-local-variable 'page-delimiter)
- (setq page-delimiter gnus-page-delimiter)
- (buffer-disable-undo (current-buffer))
- (setq buffer-read-only t) ;Disable modification
- (run-hooks 'gnus-article-mode-hook))
-
-(defun gnus-article-setup-buffer ()
- "Initialize the article buffer."
- (let* ((name (if gnus-single-article-buffer "*Article*"
- (concat "*Article " gnus-newsgroup-name "*")))
- (original
- (progn (string-match "\\*Article" name)
- (concat " *Original Article"
- (substring name (match-end 0))))))
- (setq gnus-article-buffer name)
- (setq gnus-original-article-buffer original)
- ;; This might be a variable local to the summary buffer.
- (unless gnus-single-article-buffer
- (save-excursion
- (set-buffer gnus-summary-buffer)
- (setq gnus-article-buffer name)
- (setq gnus-original-article-buffer original)
- (gnus-set-global-variables))
- (make-local-variable 'gnus-summary-buffer))
- ;; Init original article buffer.
- (save-excursion
- (set-buffer (get-buffer-create gnus-original-article-buffer))
- (buffer-disable-undo (current-buffer))
- (setq major-mode 'gnus-original-article-mode)
- (gnus-add-current-to-buffer-list)
- (make-local-variable 'gnus-original-article))
- (if (get-buffer name)
- (save-excursion
- (set-buffer name)
- (buffer-disable-undo (current-buffer))
- (setq buffer-read-only t)
- (gnus-add-current-to-buffer-list)
- (or (eq major-mode 'gnus-article-mode)
- (gnus-article-mode))
- (current-buffer))
- (save-excursion
- (set-buffer (get-buffer-create name))
- (gnus-add-current-to-buffer-list)
- (gnus-article-mode)
- (current-buffer)))))
-
-;; Set article window start at LINE, where LINE is the number of lines
-;; from the head of the article.
-(defun gnus-article-set-window-start (&optional line)
- (set-window-start
- (get-buffer-window gnus-article-buffer t)
- (save-excursion
- (set-buffer gnus-article-buffer)
- (goto-char (point-min))
- (if (not line)
- (point-min)
- (gnus-message 6 "Moved to bookmark")
- (search-forward "\n\n" nil t)
- (forward-line line)
- (point)))))
-
-(defun gnus-kill-all-overlays ()
- "Delete all overlays in the current buffer."
- (when (fboundp 'overlay-lists)
- (let* ((overlayss (overlay-lists))
- (buffer-read-only nil)
- (overlays (nconc (car overlayss) (cdr overlayss))))
- (while overlays
- (delete-overlay (pop overlays))))))
-
-(defun gnus-request-article-this-buffer (article group)
- "Get an article and insert it into this buffer."
- (let (do-update-line)
- (prog1
- (save-excursion
- (erase-buffer)
- (gnus-kill-all-overlays)
- (setq group (or group gnus-newsgroup-name))
-
- ;; Open server if it has closed.
- (gnus-check-server (gnus-find-method-for-group group))
-
- ;; Using `gnus-request-article' directly will insert the article into
- ;; `nntp-server-buffer' - so we'll save some time by not having to
- ;; copy it from the server buffer into the article buffer.
-
- ;; We only request an article by message-id when we do not have the
- ;; headers for it, so we'll have to get those.
- (when (stringp article)
- (let ((gnus-override-method gnus-refer-article-method))
- (gnus-read-header article)))
-
- ;; If the article number is negative, that means that this article
- ;; doesn't belong in this newsgroup (possibly), so we find its
- ;; message-id and request it by id instead of number.
- (when (and (numberp article)
- gnus-summary-buffer
- (get-buffer gnus-summary-buffer)
- (buffer-name (get-buffer gnus-summary-buffer)))
- (save-excursion
- (set-buffer gnus-summary-buffer)
- (let ((header (gnus-summary-article-header article)))
- (if (< article 0)
- (cond
- ((memq article gnus-newsgroup-sparse)
- ;; This is a sparse gap article.
- (setq do-update-line article)
- (setq article (mail-header-id header))
- (let ((gnus-override-method gnus-refer-article-method))
- (gnus-read-header article))
- (setq gnus-newsgroup-sparse
- (delq article gnus-newsgroup-sparse)))
- ((vectorp header)
- ;; It's a real article.
- (setq article (mail-header-id header)))
- (t
- ;; It is an extracted pseudo-article.
- (setq article 'pseudo)
- (gnus-request-pseudo-article header))))
-
- (let ((method (gnus-find-method-for-group
- gnus-newsgroup-name)))
- (if (not (eq (car method) 'nneething))
- ()
- (let ((dir (concat (file-name-as-directory (nth 1 method))
- (mail-header-subject header))))
- (if (file-directory-p dir)
- (progn
- (setq article 'nneething)
- (gnus-group-enter-directory dir)))))))))
-
- (cond
- ;; Refuse to select canceled articles.
- ((and (numberp article)
- gnus-summary-buffer
- (get-buffer gnus-summary-buffer)
- (buffer-name (get-buffer gnus-summary-buffer))
- (eq (cdr (save-excursion
- (set-buffer gnus-summary-buffer)
- (assq article gnus-newsgroup-reads)))
- gnus-canceled-mark))
- nil)
- ;; We first check `gnus-original-article-buffer'.
- ((and (get-buffer gnus-original-article-buffer)
- (numberp article)
- (save-excursion
- (set-buffer gnus-original-article-buffer)
- (and (equal (car gnus-original-article) group)
- (eq (cdr gnus-original-article) article))))
- (insert-buffer-substring gnus-original-article-buffer)
- 'article)
- ;; Check the backlog.
- ((and gnus-keep-backlog
- (gnus-backlog-request-article group article (current-buffer)))
- 'article)
- ;; Check the cache.
- ((and gnus-use-cache
- (numberp article)
- (gnus-cache-request-article article group))
- 'article)
- ;; Get the article and put into the article buffer.
- ((or (stringp article) (numberp article))
- (let ((gnus-override-method
- (and (stringp article) gnus-refer-article-method))
- (buffer-read-only nil))
- (erase-buffer)
- (gnus-kill-all-overlays)
- (if (gnus-request-article article group (current-buffer))
- (progn
- (and gnus-keep-backlog
- (numberp article)
- (gnus-backlog-enter-article
- group article (current-buffer)))
- 'article))))
- ;; It was a pseudo.
- (t article)))
-
- ;; Take the article from the original article buffer
- ;; and place it in the buffer it's supposed to be in.
- (when (and (get-buffer gnus-article-buffer)
- ;;(numberp article)
- (equal (buffer-name (current-buffer))
- (buffer-name (get-buffer gnus-article-buffer))))
- (save-excursion
- (if (get-buffer gnus-original-article-buffer)
- (set-buffer (get-buffer gnus-original-article-buffer))
- (set-buffer (get-buffer-create gnus-original-article-buffer))
- (buffer-disable-undo (current-buffer))
- (setq major-mode 'gnus-original-article-mode)
- (setq buffer-read-only t)
- (gnus-add-current-to-buffer-list))
- (let (buffer-read-only)
- (erase-buffer)
- (insert-buffer-substring gnus-article-buffer))
- (setq gnus-original-article (cons group article))))
-
- ;; Update sparse articles.
- (when (and do-update-line
- (or (numberp article)
- (stringp article)))
- (let ((buf (current-buffer)))
- (set-buffer gnus-summary-buffer)
- (gnus-summary-update-article do-update-line)
- (gnus-summary-goto-subject do-update-line nil t)
- (set-window-point (get-buffer-window (current-buffer) t)
- (point))
- (set-buffer buf))))))
-
-(defun gnus-read-header (id &optional header)
- "Read the headers of article ID and enter them into the Gnus system."
- (let ((group gnus-newsgroup-name)
- (gnus-override-method
- (and (gnus-news-group-p gnus-newsgroup-name)
- gnus-refer-article-method))
- where)
- ;; First we check to see whether the header in question is already
- ;; fetched.
- (if (stringp id)
- ;; This is a Message-ID.
- (setq header (or header (gnus-id-to-header id)))
- ;; This is an article number.
- (setq header (or header (gnus-summary-article-header id))))
- (if (and header
- (not (memq (mail-header-number header) gnus-newsgroup-sparse)))
- ;; We have found the header.
- header
- ;; We have to really fetch the header to this article.
- (when (setq where (gnus-request-head id group))
- (save-excursion
- (set-buffer nntp-server-buffer)
- (goto-char (point-max))
- (insert ".\n")
- (goto-char (point-min))
- (insert "211 ")
- (princ (cond
- ((numberp id) id)
- ((cdr where) (cdr where))
- (header (mail-header-number header))
- (t gnus-reffed-article-number))
- (current-buffer))
- (insert " Article retrieved.\n"))
- ;(when (and header
- ; (memq (mail-header-number header) gnus-newsgroup-sparse))
- ; (setcar (gnus-id-to-thread id) nil))
- (if (not (setq header (car (gnus-get-newsgroup-headers))))
- () ; Malformed head.
- (unless (memq (mail-header-number header) gnus-newsgroup-sparse)
- (if (and (stringp id)
- (not (string= (gnus-group-real-name group)
- (car where))))
- ;; If we fetched by Message-ID and the article came
- ;; from a different group, we fudge some bogus article
- ;; numbers for this article.
- (mail-header-set-number header gnus-reffed-article-number))
- (decf gnus-reffed-article-number)
- (gnus-remove-header (mail-header-number header))
- (push header gnus-newsgroup-headers)
- (setq gnus-current-headers header)
- (push (mail-header-number header) gnus-newsgroup-limit))
- header)))))
-
-(defun gnus-remove-header (number)
- "Remove header NUMBER from `gnus-newsgroup-headers'."
- (if (and gnus-newsgroup-headers
- (= number (mail-header-number (car gnus-newsgroup-headers))))
- (pop gnus-newsgroup-headers)
- (let ((headers gnus-newsgroup-headers))
- (while (and (cdr headers)
- (not (= number (mail-header-number (cadr headers)))))
- (pop headers))
- (when (cdr headers)
- (setcdr headers (cddr headers))))))
-
-(defun gnus-article-prepare (article &optional all-headers header)
- "Prepare ARTICLE in article mode buffer.
-ARTICLE should either be an article number or a Message-ID.
-If ARTICLE is an id, HEADER should be the article headers.
-If ALL-HEADERS is non-nil, no headers are hidden."
- (save-excursion
- ;; Make sure we start in a summary buffer.
- (unless (eq major-mode 'gnus-summary-mode)
- (set-buffer gnus-summary-buffer))
- (setq gnus-summary-buffer (current-buffer))
- ;; Make sure the connection to the server is alive.
- (unless (gnus-server-opened
- (gnus-find-method-for-group gnus-newsgroup-name))
- (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name))
- (gnus-request-group gnus-newsgroup-name t))
- (let* ((article (if header (mail-header-number header) article))
- (summary-buffer (current-buffer))
- (internal-hook gnus-article-internal-prepare-hook)
- (group gnus-newsgroup-name)
- result)
- (save-excursion
- (gnus-article-setup-buffer)
- (set-buffer gnus-article-buffer)
- ;; Deactivate active regions.
- (when (and (boundp 'transient-mark-mode)
- transient-mark-mode)
- (setq mark-active nil))
- (if (not (setq result (let ((buffer-read-only nil))
- (gnus-request-article-this-buffer
- article group))))
- ;; There is no such article.
- (save-excursion
- (when (and (numberp article)
- (not (memq article gnus-newsgroup-sparse)))
- (setq gnus-article-current
- (cons gnus-newsgroup-name article))
- (set-buffer gnus-summary-buffer)
- (setq gnus-current-article article)
- (gnus-summary-mark-article article gnus-canceled-mark))
- (unless (memq article gnus-newsgroup-sparse)
- (gnus-error
- 1 "No such article (may have expired or been canceled)")))
- (if (or (eq result 'pseudo) (eq result 'nneething))
- (progn
- (save-excursion
- (set-buffer summary-buffer)
- (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)
- (if (eq result 'nneething)
- (gnus-configure-windows 'summary)
- (gnus-configure-windows 'article))
- (gnus-set-global-variables))
- (gnus-set-mode-line 'article))
- ;; The result from the `request' was an actual article -
- ;; or at least some text that is now displayed in the
- ;; article buffer.
- (if (and (numberp article)
- (not (eq article gnus-current-article)))
- ;; Seems like a new article has been selected.
- ;; `gnus-current-article' must be an article number.
- (save-excursion
- (set-buffer summary-buffer)
- (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)
- gnus-article-current
- (cons gnus-newsgroup-name gnus-current-article))
- (unless (vectorp gnus-current-headers)
- (setq gnus-current-headers nil))
- (gnus-summary-show-thread)
- (run-hooks 'gnus-mark-article-hook)
- (gnus-set-mode-line 'summary)
- (and (gnus-visual-p 'article-highlight 'highlight)
- (run-hooks 'gnus-visual-mark-article-hook))
- ;; Set the global newsgroup variables here.
- ;; Suggested by Jim Sisolak
- ;; <sisolak@trans4.neep.wisc.edu>.
- (gnus-set-global-variables)
- (setq gnus-have-all-headers
- (or all-headers gnus-show-all-headers))
- (and gnus-use-cache
- (vectorp (gnus-summary-article-header article))
- (gnus-cache-possibly-enter-article
- group article
- (gnus-summary-article-header article)
- (memq article gnus-newsgroup-marked)
- (memq article gnus-newsgroup-dormant)
- (memq article gnus-newsgroup-unreads)))))
- (when (or (numberp article)
- (stringp article))
- ;; Hooks for getting information from the article.
- ;; This hook must be called before being narrowed.
- (let (buffer-read-only)
- (run-hooks 'internal-hook)
- (run-hooks 'gnus-article-prepare-hook)
- ;; Decode MIME message.
- (if gnus-show-mime
- (if (or (not gnus-strict-mime)
- (gnus-fetch-field "Mime-Version"))
- (funcall gnus-show-mime-method)
- (funcall gnus-decode-encoded-word-method)))
- ;; Perform the article display hooks.
- (run-hooks 'gnus-article-display-hook))
- ;; Do page break.
- (goto-char (point-min))
- (and gnus-break-pages (gnus-narrow-to-page)))
- (gnus-set-mode-line 'article)
- (gnus-configure-windows 'article)
- (goto-char (point-min))
- t))))))
-
-(defun gnus-article-show-all-headers ()
- "Show all article headers in article mode buffer."
- (save-excursion
- (gnus-article-setup-buffer)
- (set-buffer gnus-article-buffer)
- (let ((buffer-read-only nil))
- (gnus-unhide-text (point-min) (point-max)))))
-
-(defun gnus-article-hide-headers-if-wanted ()
- "Hide unwanted headers if `gnus-have-all-headers' is nil.
-Provided for backwards compatibility."
- (or (save-excursion (set-buffer gnus-summary-buffer) gnus-have-all-headers)
- gnus-inhibit-hiding
- (gnus-article-hide-headers)))
-
-(defsubst gnus-article-header-rank ()
- "Give the rank of the string HEADER as given by `gnus-sorted-header-list'."
- (let ((list gnus-sorted-header-list)
- (i 0))
- (while list
- (when (looking-at (car list))
- (setq list nil))
- (setq list (cdr list))
- (incf i))
- i))
-
-(defun gnus-article-hide-headers (&optional arg delete)
- "Toggle whether to hide unwanted headers and possibly sort them as well.
-If given a negative prefix, always show; if given a positive prefix,
-always hide."
- (interactive (gnus-hidden-arg))
- (if (gnus-article-check-hidden-text 'headers arg)
- ;; Show boring headers as well.
- (gnus-article-show-hidden-text 'boring-headers)
- ;; This function might be inhibited.
- (unless gnus-inhibit-hiding
- (save-excursion
- (set-buffer gnus-article-buffer)
- (save-restriction
- (let ((buffer-read-only nil)
- (props (nconc (list 'gnus-type 'headers)
- gnus-hidden-properties))
- (max (1+ (length gnus-sorted-header-list)))
- (ignored (when (not (stringp gnus-visible-headers))
- (cond ((stringp gnus-ignored-headers)
- gnus-ignored-headers)
- ((listp gnus-ignored-headers)
- (mapconcat 'identity gnus-ignored-headers
- "\\|")))))
- (visible
- (cond ((stringp gnus-visible-headers)
- gnus-visible-headers)
- ((and gnus-visible-headers
- (listp gnus-visible-headers))
- (mapconcat 'identity gnus-visible-headers "\\|"))))
- (inhibit-point-motion-hooks t)
- want-list beg)
- ;; First we narrow to just the headers.
- (widen)
- (goto-char (point-min))
- ;; Hide any "From " lines at the beginning of (mail) articles.
- (while (looking-at "From ")
- (forward-line 1))
- (unless (bobp)
- (if delete
- (delete-region (point-min) (point))
- (gnus-hide-text (point-min) (point) props)))
- ;; Then treat the rest of the header lines.
- (narrow-to-region
- (point)
- (progn (search-forward "\n\n" nil t) (forward-line -1) (point)))
- ;; Then we use the two regular expressions
- ;; `gnus-ignored-headers' and `gnus-visible-headers' to
- ;; select which header lines is to remain visible in the
- ;; article buffer.
- (goto-char (point-min))
- (while (re-search-forward "^[^ \t]*:" nil t)
- (beginning-of-line)
- ;; We add the headers we want to keep to a list and delete
- ;; them from the buffer.
- (gnus-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)
- (+ 2 max)))
- (forward-line 1))
- (message-sort-headers-1)
- (when (setq beg (text-property-any
- (point-min) (point-max) 'message-rank (+ 2 max)))
- ;; We make the unwanted headers invisible.
- (if delete
- (delete-region beg (point-max))
- ;; Suggested by Sudish Joseph <joseph@cis.ohio-state.edu>.
- (gnus-hide-text-type beg (point-max) 'headers))
- ;; Work around XEmacs lossage.
- (gnus-put-text-property (point-min) beg 'invisible nil))))))))
-
-(defun gnus-article-hide-boring-headers (&optional arg)
- "Toggle hiding of headers that aren't very interesting.
-If given a negative prefix, always show; if given a positive prefix,
-always hide."
- (interactive (gnus-hidden-arg))
- (unless (gnus-article-check-hidden-text 'boring-headers arg)
- (save-excursion
- (set-buffer gnus-article-buffer)
- (save-restriction
- (let ((buffer-read-only nil)
- (list gnus-boring-article-headers)
- (inhibit-point-motion-hooks t)
- elem)
- (nnheader-narrow-to-headers)
- (while list
- (setq elem (pop list))
- (goto-char (point-min))
- (cond
- ;; Hide empty headers.
- ((eq elem 'empty)
- (while (re-search-forward "^[^:]+:[ \t]\n[^ \t]" nil t)
- (forward-line -1)
- (gnus-hide-text-type
- (progn (beginning-of-line) (point))
- (progn
- (end-of-line)
- (if (re-search-forward "^[^ \t]" nil t)
- (match-beginning 0)
- (point-max)))
- 'boring-headers)))
- ;; Hide boring Newsgroups header.
- ((eq elem 'newsgroups)
- (when (equal (message-fetch-field "newsgroups")
- (gnus-group-real-name gnus-newsgroup-name))
- (gnus-article-hide-header "newsgroups")))
- ((eq elem 'followup-to)
- (when (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"))
- (reply-to (message-fetch-field "reply-to")))
- (when (and
- from reply-to
- (equal
- (nth 1 (funcall gnus-extract-address-components from))
- (nth 1 (funcall gnus-extract-address-components
- reply-to))))
- (gnus-article-hide-header "reply-to"))))
- ((eq elem 'date)
- (let ((date (message-fetch-field "date")))
- (when (and date
- (< (gnus-days-between date (current-time-string))
- 4))
- (gnus-article-hide-header "date")))))))))))
-
-(defun gnus-article-hide-header (header)
- (save-excursion
- (goto-char (point-min))
- (when (re-search-forward (concat "^" header ":") nil t)
- (gnus-hide-text-type
- (progn (beginning-of-line) (point))
- (progn
- (end-of-line)
- (if (re-search-forward "^[^ \t]" nil t)
- (match-beginning 0)
- (point-max)))
- 'boring-headers))))
-
-;; Written by Per Abrahamsen <amanda@iesd.auc.dk>.
-(defun gnus-article-treat-overstrike ()
- "Translate overstrikes into bold text."
- (interactive)
- (save-excursion
- (set-buffer gnus-article-buffer)
- (let ((buffer-read-only nil))
- (while (search-forward "\b" nil t)
- (let ((next (following-char))
- (previous (char-after (- (point) 2))))
- (cond
- ((eq next previous)
- (gnus-put-text-property (- (point) 2) (point) 'invisible t)
- (gnus-put-text-property (point) (1+ (point)) 'face 'bold))
- ((eq next ?_)
- (gnus-put-text-property (1- (point)) (1+ (point)) 'invisible t)
- (gnus-put-text-property
- (- (point) 2) (1- (point)) 'face 'underline))
- ((eq previous ?_)
- (gnus-put-text-property (- (point) 2) (point) 'invisible t)
- (gnus-put-text-property
- (point) (1+ (point)) 'face 'underline))))))))
-
-(defun gnus-article-word-wrap ()
- "Format too long lines."
- (interactive)
- (save-excursion
- (set-buffer gnus-article-buffer)
- (let ((buffer-read-only nil))
- (widen)
- (goto-char (point-min))
- (search-forward "\n\n" nil t)
- (end-of-line 1)
- (let ((paragraph-start "^[>|#:<;* ]*[ \t]*$")
- (adaptive-fill-regexp "[ \t]*\\([|#:<;>*]+ *\\)?")
- (adaptive-fill-mode t))
- (while (not (eobp))
- (and (>= (current-column) (min fill-column (window-width)))
- (/= (preceding-char) ?:)
- (fill-paragraph nil))
- (end-of-line 2))))))
-
-(defun gnus-article-remove-cr ()
- "Remove carriage returns from an article."
- (interactive)
- (save-excursion
- (set-buffer gnus-article-buffer)
- (let ((buffer-read-only nil))
- (goto-char (point-min))
- (while (search-forward "\r" nil t)
- (replace-match "" t t)))))
-
-(defun gnus-article-remove-trailing-blank-lines ()
- "Remove all trailing blank lines from the article."
- (interactive)
- (save-excursion
- (set-buffer gnus-article-buffer)
- (let ((buffer-read-only nil))
- (goto-char (point-max))
- (delete-region
- (point)
- (progn
- (while (looking-at "^[ \t]*$")
- (forward-line -1))
- (forward-line 1)
- (point))))))
-
-(defun gnus-article-display-x-face (&optional force)
- "Look for an X-Face header and display it if present."
- (interactive (list 'force))
- (save-excursion
- (set-buffer gnus-article-buffer)
- ;; Delete the old process, if any.
- (when (process-status "gnus-x-face")
- (delete-process "gnus-x-face"))
- (let ((inhibit-point-motion-hooks t)
- (case-fold-search nil)
- from)
- (save-restriction
- (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))
- ;; 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
- "gnus-x-face" nil shell-file-name shell-command-switch
- gnus-article-x-face-command))
- (process-send-region "gnus-x-face" beg end)
- (process-send-eof "gnus-x-face")))))))))
-
-(defalias 'gnus-headers-decode-quoted-printable 'gnus-decode-rfc1522)
-(defun gnus-decode-rfc1522 ()
- "Hack to remove QP encoding from headers."
- (let ((case-fold-search t)
- (inhibit-point-motion-hooks t)
- (buffer-read-only nil)
- string)
- (save-restriction
- (narrow-to-region
- (goto-char (point-min))
- (or (search-forward "\n\n" nil t) (point-max)))
-
- (goto-char (point-min))
- (while (re-search-forward
- "=\\?iso-8859-1\\?q\\?\\([^?\t\n]*\\)\\?=" nil t)
- (setq string (match-string 1))
- (narrow-to-region (match-beginning 0) (match-end 0))
- (delete-region (point-min) (point-max))
- (insert string)
- (gnus-mime-decode-quoted-printable (goto-char (point-min)) (point-max))
- (subst-char-in-region (point-min) (point-max) ?_ ? )
- (widen)
- (goto-char (point-min))))))
-
-(defun gnus-article-de-quoted-unreadable (&optional force)
- "Do a naive translation of a quoted-printable-encoded article.
-This is in no way, shape or form meant as a replacement for real MIME
-processing, but is simply a stop-gap measure until MIME support is
-written.
-If FORCE, decode the article whether it is marked as quoted-printable
-or not."
- (interactive (list 'force))
- (save-excursion
- (set-buffer gnus-article-buffer)
- (let ((case-fold-search t)
- (buffer-read-only nil)
- (type (gnus-fetch-field "content-transfer-encoding")))
- (gnus-decode-rfc1522)
- (when (or force
- (and type (string-match "quoted-printable" (downcase type))))
- (goto-char (point-min))
- (search-forward "\n\n" nil 'move)
- (gnus-mime-decode-quoted-printable (point) (point-max))))))
-
-(defun gnus-mime-decode-quoted-printable (from to)
- "Decode Quoted-Printable in the region between FROM and TO."
- (interactive "r")
- (goto-char from)
- (while (search-forward "=" to t)
- (cond ((eq (following-char) ?\n)
- (delete-char -1)
- (delete-char 1))
- ((looking-at "[0-9A-F][0-9A-F]")
- (subst-char-in-region
- (1- (point)) (point) ?=
- (hexl-hex-string-to-integer
- (buffer-substring (point) (+ 2 (point)))))
- (delete-char 2))
- ((looking-at "=")
- (delete-char 1))
- ((gnus-message 3 "Malformed MIME quoted-printable message")))))
-
-(defun gnus-article-hide-pgp (&optional arg)
- "Toggle hiding of any PGP headers and signatures in the current article.
-If given a negative prefix, always show; if given a positive prefix,
-always hide."
- (interactive (gnus-hidden-arg))
- (unless (gnus-article-check-hidden-text 'pgp arg)
- (save-excursion
- (set-buffer gnus-article-buffer)
- (let ((props (nconc (list 'gnus-type 'pgp) gnus-hidden-properties))
- buffer-read-only beg end)
- (widen)
- (goto-char (point-min))
- ;; Hide the "header".
- (and (search-forward "\n-----BEGIN PGP SIGNED MESSAGE-----\n" nil t)
- (gnus-hide-text (match-beginning 0) (match-end 0) props))
- (setq beg (point))
- ;; Hide the actual signature.
- (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t)
- (setq end (1+ (match-beginning 0)))
- (gnus-hide-text
- 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))
- props))
- ;; Hide "- " PGP quotation markers.
- (when (and beg end)
- (narrow-to-region beg end)
- (goto-char (point-min))
- (while (re-search-forward "^- " nil t)
- (gnus-hide-text (match-beginning 0) (match-end 0) props))
- (widen))))))
-
-(defun gnus-article-hide-pem (&optional arg)
- "Toggle hiding of any PEM headers and signatures in the current article.
-If given a negative prefix, always show; if given a positive prefix,
-always hide."
- (interactive (gnus-hidden-arg))
- (unless (gnus-article-check-hidden-text 'pem arg)
- (save-excursion
- (set-buffer gnus-article-buffer)
- (let ((props (nconc (list 'gnus-type 'pem) gnus-hidden-properties))
- buffer-read-only end)
- (widen)
- (goto-char (point-min))
- ;; hide the horrendously ugly "header".
- (and (search-forward "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n"
- nil
- t)
- (setq end (1+ (match-beginning 0)))
- (gnus-hide-text
- end
- (if (search-forward "\n\n" nil t)
- (match-end 0)
- (point-max))
- props))
- ;; hide the trailer as well
- (and (search-forward "\n-----END PRIVACY-ENHANCED MESSAGE-----\n"
- nil
- t)
- (gnus-hide-text (match-beginning 0) (match-end 0) props))))))
-
-(defun gnus-article-hide-signature (&optional arg)
- "Hide the signature in the current article.
-If given a negative prefix, always show; if given a positive prefix,
-always hide."
- (interactive (gnus-hidden-arg))
- (unless (gnus-article-check-hidden-text 'signature arg)
- (save-excursion
- (set-buffer gnus-article-buffer)
- (save-restriction
- (let ((buffer-read-only nil))
- (when (gnus-narrow-to-signature)
- (gnus-hide-text-type (point-min) (point-max) 'signature)))))))
-
-(defun gnus-article-strip-leading-blank-lines ()
- "Remove all blank lines from the beginning of the article."
- (interactive)
- (save-excursion
- (set-buffer gnus-article-buffer)
- (let (buffer-read-only)
- (goto-char (point-min))
- (when (search-forward "\n\n" nil t)
- (while (looking-at "[ \t]$")
- (gnus-delete-line))))))
-
-(defvar mime::preview/content-list)
-(defvar mime::preview-content-info/point-min)
-(defun gnus-narrow-to-signature ()
- "Narrow to the signature."
- (widen)
- (if (and (boundp 'mime::preview/content-list)
- mime::preview/content-list)
- (let ((pcinfo (car (last mime::preview/content-list))))
- (condition-case ()
- (narrow-to-region
- (funcall (intern "mime::preview-content-info/point-min") pcinfo)
- (point-max))
- (error nil))))
- (goto-char (point-max))
- (when (re-search-backward gnus-signature-separator nil t)
- (forward-line 1)
- (when (or (null gnus-signature-limit)
- (and (numberp gnus-signature-limit)
- (< (- (point-max) (point)) gnus-signature-limit))
- (and (gnus-functionp gnus-signature-limit)
- (funcall gnus-signature-limit))
- (and (stringp gnus-signature-limit)
- (not (re-search-forward gnus-signature-limit nil t))))
- (narrow-to-region (point) (point-max))
- t)))
-
-(defun gnus-hidden-arg ()
- "Return the current prefix arg as a number, or 0 if no prefix."
- (list (if current-prefix-arg
- (prefix-numeric-value current-prefix-arg)
- 0)))
-
-(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
-means show, 0 means toggle."
- (save-excursion
- (set-buffer gnus-article-buffer)
- (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) 'gnus-type type)))
- (when pos
- (if (get-text-property pos 'invisible)
- 'hidden
- 'shown))))
-
-(defun gnus-article-hide (&optional arg force)
- "Hide all the gruft in the current article.
-This means that PGP stuff, signatures, cited text and (some)
-headers will be hidden.
-If given a prefix, show the hidden text instead."
- (interactive (list current-prefix-arg 'force))
- (gnus-article-hide-headers arg)
- (gnus-article-hide-pgp arg)
- (gnus-article-hide-citation-maybe arg force)
- (gnus-article-hide-signature arg))
-
-(defun gnus-article-show-hidden-text (type &optional hide)
- "Show all hidden text of type TYPE.
-If HIDE, hide the text instead."
- (save-excursion
- (set-buffer gnus-article-buffer)
- (let ((buffer-read-only nil)
- (inhibit-point-motion-hooks t)
- (beg (point-min)))
- (while (gnus-goto-char (text-property-any
- beg (point-max) 'gnus-type type))
- (setq beg (point))
- (forward-char)
- (if hide
- (gnus-hide-text beg (point) gnus-hidden-properties)
- (gnus-unhide-text beg (point)))
- (setq beg (point)))
- t)))
-
-(defvar gnus-article-time-units
- `((year . ,(* 365.25 24 60 60))
- (week . ,(* 7 24 60 60))
- (day . ,(* 24 60 60))
- (hour . ,(* 60 60))
- (minute . 60)
- (second . 1))
- "Mapping from time units to seconds.")
-
-(defun gnus-article-date-ut (&optional type highlight)
- "Convert DATE date to universal time in the current article.
-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 gnus-current-headers
- (gnus-summary-article-header) ""))
- (date (and (vectorp header) (mail-header-date header)))
- (date-regexp "^Date: \\|^X-Sent: ")
- (now (current-time))
- (inhibit-point-motion-hooks t)
- bface eface)
- (when (and date (not (string= date "")))
- (save-excursion
- (set-buffer gnus-article-buffer)
- (save-restriction
- (nnheader-narrow-to-headers)
- (let ((buffer-read-only nil))
- ;; Delete any old Date headers.
- (if (re-search-forward date-regexp nil t)
- (progn
- (setq bface (get-text-property (gnus-point-at-bol) 'face)
- eface (get-text-property (1- (gnus-point-at-eol))
- 'face))
- (message-remove-header date-regexp t)
- (beginning-of-line))
- (goto-char (point-max)))
- (insert (gnus-make-date-line date type))
- ;; Do highlighting.
- (forward-line -1)
- (when (and (gnus-visual-p 'article-highlight 'highlight)
- (looking-at "\\([^:]+\\): *\\(.*\\)$"))
- (gnus-put-text-property (match-beginning 1) (match-end 1)
- 'face bface)
- (gnus-put-text-property (match-beginning 2) (match-end 2)
- 'face eface))))))))
-
-(defun gnus-make-date-line (date type)
- "Return a DATE line of TYPE."
- (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)
- (concat "Date: " (condition-case ()
- (timezone-make-date-arpa-standard date)
- (error date))
- "\n"))
- ;; Convert to Universal Time.
- ((eq type 'ut)
- (concat "Date: "
- (condition-case ()
- (timezone-make-date-arpa-standard date nil "UT")
- (error date))
- "\n"))
- ;; Get the original date from the article.
- ((eq type 'original)
- (concat "Date: " date "\n"))
- ;; 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 condition-case
- ;; the entire thing.
- (let* ((now (current-time))
- (real-time
- (condition-case ()
- (gnus-time-minus
- (gnus-encode-date
- (timezone-make-date-arpa-standard
- (current-time-string now)
- (current-time-zone now) "UT"))
- (gnus-encode-date
- (timezone-make-date-arpa-standard
- date nil "UT")))
- (error '(0 0))))
- (real-sec (+ (* (float (car real-time)) 65536)
- (cadr real-time)))
- (sec (abs real-sec))
- num prev)
- (cond
- ((equal real-time '(0 0))
- "X-Sent: Unknown\n")
- ((zerop sec)
- "X-Sent: Now\n")
- (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))))
- gnus-article-time-units "")
- ;; If dates are odd, then it might appear like the
- ;; article was sent in the future.
- (if (> real-sec 0)
- " ago\n"
- " in the future\n"))))))
- (t
- (error "Unknown conversion type: %s" type))))
-
-(defun gnus-article-date-local (&optional highlight)
- "Convert the current article date to the local timezone."
- (interactive (list t))
- (gnus-article-date-ut 'local highlight))
-
-(defun gnus-article-date-original (&optional highlight)
- "Convert the current article date to what it was originally.
-This is only useful if you have used some other date conversion
-function and want to see what the date was before converting."
- (interactive (list t))
- (gnus-article-date-ut 'original highlight))
-
-(defun gnus-article-date-lapsed (&optional highlight)
- "Convert the current article date to time lapsed since it was sent."
- (interactive (list t))
- (gnus-article-date-ut 'lapsed highlight))
-
-(defun gnus-article-maybe-highlight ()
- "Do some article highlighting if `gnus-visual' is non-nil."
- (if (gnus-visual-p 'article-highlight 'highlight)
- (gnus-article-highlight-some)))
-
-;;; 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))
- (write-region (point-min) (point-max) file-name t 1)))
- (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.
- (if msg
- (progn (widen)
- (narrow-to-region (point-max) (point-max))))
- (insert-buffer-substring tmpbuf)
- (if msg
- (progn
- (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)))
- (nnheader-temp-write nil
- (insert-buffer-substring artbuf)
- ;; Append newline at end of the buffer as separator, and then
- ;; 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 "\^_")))
-
-(defun gnus-narrow-to-page (&optional arg)
- "Narrow the article buffer to a page.
-If given a numerical ARG, move forward ARG pages."
- (interactive "P")
- (setq arg (if arg (prefix-numeric-value arg) 0))
- (save-excursion
- (set-buffer gnus-article-buffer)
- (goto-char (point-min))
- (widen)
- (when (gnus-visual-p 'page-marker)
- (let ((buffer-read-only nil))
- (gnus-remove-text-with-property 'gnus-prev)
- (gnus-remove-text-with-property 'gnus-next)))
- (when
- (cond ((< arg 0)
- (re-search-backward page-delimiter nil 'move (1+ (abs arg))))
- ((> arg 0)
- (re-search-forward page-delimiter nil 'move arg)))
- (goto-char (match-end 0)))
- (narrow-to-region
- (point)
- (if (re-search-forward page-delimiter nil 'move)
- (match-beginning 0)
- (point)))
- (when (and (gnus-visual-p 'page-marker)
- (not (= (point-min) 1)))
- (save-excursion
- (goto-char (point-min))
- (gnus-insert-prev-page-button)))
- (when (and (gnus-visual-p 'page-marker)
- (not (= (1- (point-max)) (buffer-size))))
- (save-excursion
- (goto-char (point-max))
- (gnus-insert-next-page-button)))))
-
-;; Article mode commands
-
-(defun gnus-article-goto-next-page ()
- "Show the next page of the article."
- (interactive)
- (when (gnus-article-next-page)
- (gnus-article-read-summary-keys nil (gnus-character-to-event ?n))))
-
-(defun gnus-article-goto-prev-page ()
- "Show the next page of the article."
- (interactive)
- (if (bobp) (gnus-article-read-summary-keys nil (gnus-character-to-event ?n))
- (gnus-article-prev-page nil)))
-
-(defun gnus-article-next-page (&optional lines)
- "Show the next page of the current article.
-If end of article, return non-nil. Otherwise return nil.
-Argument LINES specifies lines to be scrolled up."
- (interactive "p")
- (move-to-window-line -1)
- ;; Fixed by enami@ptgd.sony.co.jp (enami tsugutomo)
- (if (save-excursion
- (end-of-line)
- (and (pos-visible-in-window-p) ;Not continuation line.
- (eobp)))
- ;; Nothing in this page.
- (if (or (not gnus-break-pages)
- (save-excursion
- (save-restriction
- (widen) (forward-line 1) (eobp)))) ;Real end-of-buffer?
- t ;Nothing more.
- (gnus-narrow-to-page 1) ;Go to next page.
- nil)
- ;; More in this page.
- (condition-case ()
- (scroll-up lines)
- (end-of-buffer
- ;; Long lines may cause an end-of-buffer error.
- (goto-char (point-max))))
- (move-to-window-line 0)
- nil))
-
-(defun gnus-article-prev-page (&optional lines)
- "Show previous page of current article.
-Argument LINES specifies lines to be scrolled down."
- (interactive "p")
- (move-to-window-line 0)
- (if (and gnus-break-pages
- (bobp)
- (not (save-restriction (widen) (bobp)))) ;Real beginning-of-buffer?
- (progn
- (gnus-narrow-to-page -1) ;Go to previous page.
- (goto-char (point-max))
- (recenter -1))
- (prog1
- (condition-case ()
- (scroll-down lines)
- (error nil))
- (move-to-window-line 0))))
-
-(defun gnus-article-refer-article ()
- "Read article specified by message-id around point."
- (interactive)
- (let ((point (point)))
- (search-forward ">" nil t) ;Move point to end of "<....>".
- (if (re-search-backward "\\(<[^<> \t\n]+>\\)" nil t)
- (let ((message-id (match-string 1)))
- (goto-char point)
- (set-buffer gnus-summary-buffer)
- (gnus-summary-refer-article message-id))
- (goto-char (point))
- (error "No references around point"))))
-
-(defun gnus-article-show-summary ()
- "Reconfigure windows to show summary buffer."
- (interactive)
- (gnus-configure-windows 'article)
- (gnus-summary-goto-subject gnus-current-article))
-
-(defun gnus-article-describe-briefly ()
- "Describe article mode commands briefly."
- (interactive)
- (gnus-message 6
- (substitute-command-keys "\\<gnus-article-mode-map>\\[gnus-article-goto-next-page]:Next page \\[gnus-article-goto-prev-page]:Prev page \\[gnus-article-show-summary]:Show summary \\[gnus-info-find-node]:Run Info \\[gnus-article-describe-briefly]:This help")))
-
-(defun gnus-article-summary-command ()
- "Execute the last keystroke in the summary buffer."
- (interactive)
- (let ((obuf (current-buffer))
- (owin (current-window-configuration))
- func)
- (switch-to-buffer gnus-summary-buffer 'norecord)
- (setq func (lookup-key (current-local-map) (this-command-keys)))
- (call-interactively func)
- (set-buffer obuf)
- (set-window-configuration owin)
- (set-window-point (get-buffer-window (current-buffer)) (point))))
-
-(defun gnus-article-summary-command-nosave ()
- "Execute the last keystroke in the summary buffer."
- (interactive)
- (let (func)
- (pop-to-buffer gnus-summary-buffer 'norecord)
- (setq func (lookup-key (current-local-map) (this-command-keys)))
- (call-interactively func)))
-
-(defun gnus-article-read-summary-keys (&optional arg key not-restore-window)
- "Read a summary buffer key sequence and execute it from the article buffer."
- (interactive "P")
- (let ((nosaves
- '("q" "Q" "c" "r" "R" "\C-c\C-f" "m" "a" "f" "F"
- "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"
- "=" "^" "\M-^" "|"))
- (nosave-but-article
- '("A\r"))
- keys)
- (save-excursion
- (set-buffer gnus-summary-buffer)
- (push (or key last-command-event) unread-command-events)
- (setq keys (read-key-sequence nil)))
- (message "")
-
- (if (or (member keys nosaves)
- (member keys nosave-but-article))
- (let (func)
- (save-window-excursion
- (pop-to-buffer gnus-summary-buffer 'norecord)
- (setq func (lookup-key (current-local-map) keys)))
- (if (not func)
- (ding)
- (set-buffer gnus-summary-buffer)
- (call-interactively func))
- (when (member keys nosave-but-article)
- (pop-to-buffer gnus-article-buffer 'norecord)))
- (let ((obuf (current-buffer))
- (owin (current-window-configuration))
- (opoint (point))
- func in-buffer)
- (if not-restore-window
- (pop-to-buffer gnus-summary-buffer 'norecord)
- (switch-to-buffer gnus-summary-buffer 'norecord))
- (setq in-buffer (current-buffer))
- (if (setq func (lookup-key (current-local-map) keys))
- (call-interactively func)
- (ding))
- (when (eq in-buffer (current-buffer))
- (set-buffer obuf)
- (unless not-restore-window
- (set-window-configuration owin))
- (set-window-point (get-buffer-window (current-buffer)) opoint))))))
-