(require 'gnus-int)
(require 'gnus-range)
(require 'gnus-win)
+(require 'gnus-undo)
(defvar gnus-group-archive-directory
"/ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list/"
"*Default listing level.
Ignored if `gnus-group-use-permanent-levels' is non-nil.")
-(defvar gnus-group-use-permanent-levels nil
- "*If non-nil, once you set a level, Gnus will use this level.")
-
(defvar gnus-group-list-inactive-groups t
"*If non-nil, inactive groups will be listed.")
"*Function used for sorting the group buffer.
This function will be called with group info entries as the arguments
for the groups to be sorted. Pre-made functions include
-`gnus-group-sort-by-alphabet', `gnus-group-sort-by-unread',
-`gnus-group-sort-by-level', `gnus-group-sort-by-score',
-`gnus-group-sort-by-method', and `gnus-group-sort-by-rank'.
+`gnus-group-sort-by-alphabet', `gnus-group-sort-by-real-name',
+`gnus-group-sort-by-unread', `gnus-group-sort-by-level',
+`gnus-group-sort-by-score', `gnus-group-sort-by-method', and
+`gnus-group-sort-by-rank'.
This variable can also be a list of sorting functions. In that case,
the most significant sort function should be the last function in the
%i Number of ticked and dormant (integer)
%T Number of ticked articles (integer)
%R Number of read articles (integer)
-%t Total number of articles (integer)
+%t Estimated total number of articles (integer)
%y Number of unread, unticked articles (integer)
%G Group name (string)
%g Qualified group name (string)
(defvar gnus-group-mode-hook nil
"*A hook for Gnus group mode.")
+(defvar gnus-group-menu-hook nil
+ "*Hook run after the creation of the group mode menu.")
+
(defvar gnus-group-catchup-group-hook nil
"*A hook run when catching up a group from the group buffer.")
(defvar gnus-group-indentation-function nil)
(defvar gnus-goto-missing-group-function nil)
+(defvar gnus-group-get-parameter-function 'gnus-group-get-parameter)
(defvar gnus-group-goto-next-group-function nil
"Function to override finding the next group after listing groups.")
;;; Gnus group mode
;;;
-(defvar gnus-group-mode-map nil)
(put 'gnus-group-mode 'mode-class 'special)
-(unless gnus-group-mode-map
- (setq gnus-group-mode-map (make-keymap))
- (suppress-keymap gnus-group-mode-map)
-
+(when t
(gnus-define-keys gnus-group-mode-map
" " gnus-group-read-group
"=" gnus-group-select-group
"U" gnus-group-unsubscribe-group
"c" gnus-group-catchup-current
"C" gnus-group-catchup-current-all
+ "\M-c" gnus-group-clear-data
"l" gnus-group-list-groups
"L" gnus-group-list-all-groups
"m" gnus-group-mail
"V" gnus-version
"s" gnus-group-save-newsrc
"z" gnus-group-suspend
-; "Z" gnus-group-clear-dribble
+ ; "Z" gnus-group-clear-dribble
"q" gnus-group-exit
"Q" gnus-group-quit
"?" gnus-group-describe-briefly
"V" gnus-group-make-empty-virtual
"D" gnus-group-enter-directory
"f" gnus-group-make-doc-group
+ "n" gnus-group-make-web-group
"r" gnus-group-rename-group
"\177" gnus-group-delete-group
[delete] gnus-group-delete-group)
- (gnus-define-keys (gnus-group-soup-map "s" gnus-group-group-map)
- "b" gnus-group-brew-soup
- "w" gnus-soup-save-areas
- "s" gnus-soup-send-replies
- "p" gnus-soup-pack-packet
- "r" nnsoup-pack-replies)
-
- (gnus-define-keys (gnus-group-sort-map "S" gnus-group-group-map)
- "s" gnus-group-sort-groups
- "a" gnus-group-sort-groups-by-alphabet
- "u" gnus-group-sort-groups-by-unread
- "l" gnus-group-sort-groups-by-level
- "v" gnus-group-sort-groups-by-score
- "r" gnus-group-sort-groups-by-rank
- "m" gnus-group-sort-groups-by-method)
-
- (gnus-define-keys (gnus-group-list-map "A" gnus-group-mode-map)
- "k" gnus-group-list-killed
- "z" gnus-group-list-zombies
- "s" gnus-group-list-groups
- "u" gnus-group-list-all-groups
- "A" gnus-group-list-active
- "a" gnus-group-apropos
- "d" gnus-group-description-apropos
- "m" gnus-group-list-matching
- "M" gnus-group-list-all-matching
- "l" gnus-group-list-level)
-
- (gnus-define-keys (gnus-group-score-map "W" gnus-group-mode-map)
- "f" gnus-score-flush-cache)
-
- (gnus-define-keys (gnus-group-help-map "H" gnus-group-mode-map)
- "f" gnus-group-fetch-faq)
-
- (gnus-define-keys (gnus-group-sub-map "S" gnus-group-mode-map)
- "l" gnus-group-set-current-level
- "t" gnus-group-unsubscribe-current-group
- "s" gnus-group-unsubscribe-group
- "k" gnus-group-kill-group
- "y" gnus-group-yank-group
- "w" gnus-group-kill-region
- "\C-k" gnus-group-kill-level
- "z" gnus-group-kill-all-zombies))
+ (gnus-define-keys (gnus-group-soup-map "s" gnus-group-group-map)
+ "b" gnus-group-brew-soup
+ "w" gnus-soup-save-areas
+ "s" gnus-soup-send-replies
+ "p" gnus-soup-pack-packet
+ "r" nnsoup-pack-replies)
+
+ (gnus-define-keys (gnus-group-sort-map "S" gnus-group-group-map)
+ "s" gnus-group-sort-groups
+ "a" gnus-group-sort-groups-by-alphabet
+ "u" gnus-group-sort-groups-by-unread
+ "l" gnus-group-sort-groups-by-level
+ "v" gnus-group-sort-groups-by-score
+ "r" gnus-group-sort-groups-by-rank
+ "m" gnus-group-sort-groups-by-method)
+
+ (gnus-define-keys (gnus-group-list-map "A" gnus-group-mode-map)
+ "k" gnus-group-list-killed
+ "z" gnus-group-list-zombies
+ "s" gnus-group-list-groups
+ "u" gnus-group-list-all-groups
+ "A" gnus-group-list-active
+ "a" gnus-group-apropos
+ "d" gnus-group-description-apropos
+ "m" gnus-group-list-matching
+ "M" gnus-group-list-all-matching
+ "l" gnus-group-list-level)
+
+ (gnus-define-keys (gnus-group-score-map "W" gnus-group-mode-map)
+ "f" gnus-score-flush-cache)
+
+ (gnus-define-keys (gnus-group-help-map "H" gnus-group-mode-map)
+ "f" gnus-group-fetch-faq)
+
+ (gnus-define-keys (gnus-group-sub-map "S" gnus-group-mode-map)
+ "l" gnus-group-set-current-level
+ "t" gnus-group-unsubscribe-current-group
+ "s" gnus-group-unsubscribe-group
+ "k" gnus-group-kill-group
+ "y" gnus-group-yank-group
+ "w" gnus-group-kill-region
+ "\C-k" gnus-group-kill-level
+ "z" gnus-group-kill-all-zombies))
+
+
+(defun gnus-group-make-menu-bar ()
+ (gnus-turn-off-edit-menu 'group)
+ (unless (boundp 'gnus-group-reading-menu)
+
+ (easy-menu-define
+ gnus-group-reading-menu gnus-group-mode-map ""
+ '("Group"
+ ["Read" gnus-group-read-group (gnus-group-group-name)]
+ ["Select" gnus-group-select-group (gnus-group-group-name)]
+ ["See old articles" (gnus-group-select-group 'all)
+ :keys "C-u SPC" :active (gnus-group-group-name)]
+ ["Catch up" gnus-group-catchup-current (gnus-group-group-name)]
+ ["Catch up all articles" gnus-group-catchup-current-all
+ (gnus-group-group-name)]
+ ["Check for new articles" gnus-group-get-new-news-this-group
+ (gnus-group-group-name)]
+ ["Toggle subscription" gnus-group-unsubscribe-current-group
+ (gnus-group-group-name)]
+ ["Kill" gnus-group-kill-group (gnus-group-group-name)]
+ ["Yank" gnus-group-yank-group gnus-list-of-killed-groups]
+ ["Describe" gnus-group-describe-group (gnus-group-group-name)]
+ ["Fetch FAQ" gnus-group-fetch-faq (gnus-group-group-name)]
+ ["Edit kill file" gnus-group-edit-local-kill
+ (gnus-group-group-name)]
+ ;; Actually one should check, if any of the marked groups gives t for
+ ;; (gnus-check-backend-function 'request-expire-articles ...)
+ ["Expire articles" gnus-group-expire-articles
+ (or (and (gnus-group-group-name)
+ (gnus-check-backend-function
+ 'request-expire-articles
+ (gnus-group-group-name))) gnus-group-marked)]
+ ["Set group level" gnus-group-set-current-level
+ (gnus-group-group-name)]
+ ["Select quick" gnus-group-quick-select-group (gnus-group-group-name)]
+ ))
+
+ (easy-menu-define
+ gnus-group-group-menu gnus-group-mode-map ""
+ '("Groups"
+ ("Listing"
+ ["List unread subscribed groups" gnus-group-list-groups t]
+ ["List (un)subscribed groups" gnus-group-list-all-groups t]
+ ["List killed groups" gnus-group-list-killed gnus-killed-list]
+ ["List zombie groups" gnus-group-list-zombies gnus-zombie-list]
+ ["List level..." gnus-group-list-level t]
+ ["Describe all groups" gnus-group-describe-all-groups t]
+ ["Group apropos..." gnus-group-apropos t]
+ ["Group and description apropos..." gnus-group-description-apropos t]
+ ["List groups matching..." gnus-group-list-matching t]
+ ["List all groups matching..." gnus-group-list-all-matching t]
+ ["List active file" gnus-group-list-active t])
+ ("Sort"
+ ["Default sort" gnus-group-sort-groups
+ (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))]
+ ["Sort by method" gnus-group-sort-groups-by-method
+ (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))]
+ ["Sort by rank" gnus-group-sort-groups-by-rank
+ (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))]
+ ["Sort by score" gnus-group-sort-groups-by-score
+ (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))]
+ ["Sort by level" gnus-group-sort-groups-by-level
+ (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))]
+ ["Sort by unread" gnus-group-sort-groups-by-unread
+ (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))]
+ ["Sort by name" gnus-group-sort-groups-by-alphabet
+ (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))])
+ ("Mark"
+ ["Mark group" gnus-group-mark-group
+ (and (gnus-group-group-name)
+ (not (memq (gnus-group-group-name) gnus-group-marked)))]
+ ["Unmark group" gnus-group-unmark-group
+ (and (gnus-group-group-name)
+ (memq (gnus-group-group-name) gnus-group-marked))]
+ ["Unmark all" gnus-group-unmark-all-groups gnus-group-marked]
+ ["Mark regexp..." gnus-group-mark-regexp t]
+ ["Mark region" gnus-group-mark-region t]
+ ["Mark buffer" gnus-group-mark-buffer t]
+ ["Execute command" gnus-group-universal-argument
+ (or gnus-group-marked (gnus-group-group-name))])
+ ("Subscribe"
+ ["Subscribe to a group" gnus-group-unsubscribe-group t]
+ ["Kill all newsgroups in region" gnus-group-kill-region t]
+ ["Kill all zombie groups" gnus-group-kill-all-zombies
+ gnus-zombie-list]
+ ["Kill all groups on level..." gnus-group-kill-level t])
+ ("Foreign groups"
+ ["Make a foreign group" gnus-group-make-group t]
+ ["Add a directory group" gnus-group-make-directory-group t]
+ ["Add the help group" gnus-group-make-help-group t]
+ ["Add the archive group" gnus-group-make-archive-group t]
+ ["Make a doc group" gnus-group-make-doc-group t]
+ ["Make a kiboze group" gnus-group-make-kiboze-group t]
+ ["Make a virtual group" gnus-group-make-empty-virtual t]
+ ["Add a group to a virtual" gnus-group-add-to-virtual t]
+ ["Rename group" gnus-group-rename-group
+ (gnus-check-backend-function
+ 'request-rename-group (gnus-group-group-name))]
+ ["Delete group" gnus-group-delete-group
+ (gnus-check-backend-function
+ 'request-delete-group (gnus-group-group-name))])
+ ("Editing groups"
+ ["Parameters" gnus-group-edit-group-parameters
+ (gnus-group-group-name)]
+ ["Select method" gnus-group-edit-group-method
+ (gnus-group-group-name)]
+ ["Info" gnus-group-edit-group (gnus-group-group-name)])
+ ("Score file"
+ ["Flush cache" gnus-score-flush-cache t])
+ ("Move"
+ ["Next" gnus-group-next-group t]
+ ["Previous" gnus-group-prev-group t]
+ ["Next unread" gnus-group-next-unread-group t]
+ ["Previous unread" gnus-group-prev-unread-group t]
+ ["Next unread same level" gnus-group-next-unread-group-same-level t]
+ ["Previous unread same level"
+ gnus-group-previous-unread-group-same-level t]
+ ["Jump to group" gnus-group-jump-to-group t]
+ ["First unread group" gnus-group-first-unread-group t]
+ ["Best unread group" gnus-group-best-unread-group t])
+ ["Transpose" gnus-group-transpose-groups
+ (gnus-group-group-name)]
+ ["Read a directory as a group..." gnus-group-enter-directory t]
+ ))
+
+ (easy-menu-define
+ gnus-group-misc-menu gnus-group-mode-map ""
+ '("Misc"
+ ["Send a bug report" gnus-bug t]
+ ["Send a mail" gnus-group-mail t]
+ ["Post an article..." gnus-group-post-news t]
+ ["Customize score file" gnus-score-customize t]
+ ["Check for new news" gnus-group-get-new-news t]
+ ["Activate all groups" gnus-activate-all-groups t]
+ ["Delete bogus groups" gnus-group-check-bogus-groups t]
+ ["Find new newsgroups" gnus-find-new-newsgroups t]
+ ["Restart Gnus" gnus-group-restart t]
+ ["Read init file" gnus-group-read-init-file t]
+ ["Browse foreign server" gnus-group-browse-foreign-server t]
+ ["Enter server buffer" gnus-group-enter-server-mode t]
+ ["Expire all expirable articles" gnus-group-expire-all-groups t]
+ ["Generate any kiboze groups" nnkiboze-generate-groups t]
+ ["Gnus version" gnus-version t]
+ ["Save .newsrc files" gnus-group-save-newsrc t]
+ ["Suspend Gnus" gnus-group-suspend t]
+ ["Clear dribble buffer" gnus-group-clear-dribble t]
+ ["Edit global kill file" gnus-group-edit-global-kill t]
+ ["Read manual" gnus-info-find-node t]
+ ["Toggle topics" gnus-topic-mode t]
+ ("SOUP"
+ ["Pack replies" nnsoup-pack-replies (fboundp 'nnsoup-request-group)]
+ ["Send replies" gnus-soup-send-replies
+ (fboundp 'gnus-soup-pack-packet)]
+ ["Pack packet" gnus-soup-pack-packet (fboundp 'gnus-soup-pack-packet)]
+ ["Save areas" gnus-soup-save-areas (fboundp 'gnus-soup-pack-packet)]
+ ["Brew SOUP" gnus-soup-brew-soup (fboundp 'gnus-soup-pack-packet)])
+ ["Exit from Gnus" gnus-group-exit t]
+ ["Exit without saving" gnus-group-quit t]
+ ))
+
+ (run-hooks 'gnus-group-menu-hook)
+ ))
(defun gnus-group-mode ()
"Major mode for reading news.
(buffer-disable-undo (current-buffer))
(setq truncate-lines t)
(setq buffer-read-only t)
+ (gnus-set-default-directory)
(gnus-update-format-specifications nil 'group 'group-mode)
(gnus-update-group-mark-positions)
(gnus-make-local-hook 'post-command-hook)
(gnus-add-hook 'post-command-hook 'gnus-clear-inboxes-moved nil t)
+ (when gnus-use-undo
+ (gnus-undo-mode 1))
(run-hooks 'gnus-group-mode-hook))
(defun gnus-update-group-mark-positions ()
Default is all subscribed groups.
If argument UNREAD is non-nil, groups with no unread articles are also
listed."
- (interactive (list (if current-prefix-arg
- (prefix-numeric-value current-prefix-arg)
- (or
- (gnus-group-default-level nil t)
- gnus-group-default-list-level
- gnus-level-subscribed))))
- (or level
- (setq level (car gnus-group-list-mode)
- unread (cdr gnus-group-list-mode)))
+ (interactive
+ (list (if current-prefix-arg
+ (prefix-numeric-value current-prefix-arg)
+ (or
+ (gnus-group-default-level nil t)
+ gnus-group-default-list-level
+ gnus-level-subscribed))))
+ (unless level
+ (setq level (car gnus-group-list-mode)
+ unread (cdr gnus-group-list-mode)))
(setq level (gnus-group-default-level level))
(gnus-group-setup-buffer) ;May call from out of group buffer
(gnus-update-format-specifications)
;; has disappeared in the new listing, try to find the next
;; one. If no next one can be found, just leave point at the
;; first newsgroup in the buffer.
- (if (not (gnus-goto-char
- (text-property-any
- (point-min) (point-max)
- 'gnus-group (gnus-intern-safe group gnus-active-hashtb))))
- (let ((newsrc (cdddr (gnus-gethash group gnus-newsrc-hashtb))))
- (while (and newsrc
- (not (gnus-goto-char
- (text-property-any
- (point-min) (point-max) 'gnus-group
- (gnus-intern-safe
- (caar newsrc) gnus-active-hashtb)))))
- (setq newsrc (cdr newsrc)))
- (or newsrc (progn (goto-char (point-max))
- (forward-line -1)))))))
+ (when (not (gnus-goto-char
+ (text-property-any
+ (point-min) (point-max)
+ 'gnus-group (gnus-intern-safe
+ group gnus-active-hashtb))))
+ (let ((newsrc (cdddr (gnus-gethash group gnus-newsrc-hashtb))))
+ (while (and newsrc
+ (not (gnus-goto-char
+ (text-property-any
+ (point-min) (point-max) 'gnus-group
+ (gnus-intern-safe
+ (caar newsrc) gnus-active-hashtb)))))
+ (setq newsrc (cdr newsrc)))
+ (unless newsrc
+ (goto-char (point-max))
+ (forward-line -1))))))
;; Adjust cursor point.
(gnus-group-position-point))))
(not (gnus-ephemeral-group-p group))
(gnus-dribble-enter
(concat "(gnus-group-set-info '"
- (prin1-to-string (nth 2 entry)) ")")))
+ (gnus-prin1-to-string (nth 2 entry)) ")")))
(setq gnus-group-indentation (gnus-group-group-indentation))
(gnus-delete-line)
(gnus-group-insert-group-line-info group)
;; Allow XEmacs to remove front-sticky text properties.
(gnus-group-remove-excess-properties)))
+(defun gnus-group-highlight-line ()
+ "Highlight the current line according to `gnus-group-highlight'."
+ (let* ((list gnus-group-highlight)
+ (p (point))
+ (end (progn (end-of-line) (point)))
+ ;; now find out where the line starts and leave point there.
+ (beg (progn (beginning-of-line) (point)))
+ (group (gnus-group-group-name))
+ (entry (gnus-group-entry group))
+ (unread (if (numberp (car entry)) (car entry) 0))
+ (active (gnus-active group))
+ (total (if active (1+ (- (cdr active) (car active))) 0))
+ (info (nth 2 entry))
+ (method (gnus-server-get-method group (gnus-info-method info)))
+ (marked (gnus-info-marks info))
+ (mailp (memq 'mail (assoc (symbol-name
+ (car (or method gnus-select-method)))
+ gnus-valid-select-methods)))
+ (level (or (gnus-info-level info) 9))
+ (score (or (gnus-info-score info) 0))
+ (ticked (gnus-range-length (cdr (assq 'tick marked))))
+ (inhibit-read-only t))
+ ;; Eval the cars of the lists until we find a match.
+ (while (and list
+ (not (eval (caar list))))
+ (setq list (cdr list)))
+ (let ((face (cdar list)))
+ (unless (eq face (get-text-property beg 'face))
+ (gnus-put-text-property
+ beg end 'face
+ (setq face (if (boundp face) (symbol-value face) face)))
+ (gnus-extent-start-open beg)))
+ (goto-char p)))
+
(defun gnus-group-update-group (group &optional visible-only)
"Update all lines where GROUP appear.
If VISIBLE-ONLY is non-nil, the group won't be displayed if it isn't
(let ((entry (gnus-gethash group gnus-newsrc-hashtb)))
(if (and entry (not (gnus-ephemeral-group-p group)))
(gnus-dribble-enter
- (concat "(gnus-group-set-info '" (prin1-to-string (nth 2 entry))
+ (concat "(gnus-group-set-info '"
+ (gnus-prin1-to-string (nth 2 entry))
")"))))
;; Find all group instances. If topics are in use, each group
;; may be listed in more than once.
(while (and (> n 0)
(not (eobp)))
(when (setq group (gnus-group-group-name))
- ;; Update the mark.
+ ;; Go to the mark position.
(beginning-of-line)
- (forward-char
- (or (cdr (assq 'process gnus-group-mark-positions)) 2))
- (delete-char 1)
- (if unmark
- (progn
- (insert " ")
- (setq gnus-group-marked (delete group gnus-group-marked)))
- (insert "#")
- (setq gnus-group-marked
- (cons group (delete group gnus-group-marked)))))
- (or no-advance (gnus-group-next-group 1))
+ (forward-char (or (cdr (assq 'process gnus-group-mark-positions)) 2))
+ (subst-char-in-region
+ (point) (1+ (point)) (following-char)
+ (if unmark
+ (progn
+ (setq gnus-group-marked (delete group gnus-group-marked))
+ ? )
+ (setq gnus-group-marked
+ (cons group (delete group gnus-group-marked)))
+ gnus-process-mark)))
+ (unless no-advance
+ (gnus-group-next-group 1))
(decf n))
(gnus-summary-position-point)
n))
(- (1+ (cdr active)) (car active)))))
(gnus-summary-read-group
group (or all (and (numberp number)
- (zerop (+ number (length (cdr (assq 'tick marked)))
- (length (cdr (assq 'dormant marked)))))))
+ (zerop (+ number (gnus-range-length
+ (cdr (assq 'tick marked)))
+ (gnus-range-length
+ (cdr (assq 'dormant marked)))))))
no-article)))
(defun gnus-group-select-group (&optional all)
;; Enter a group that is not in the group buffer. Non-nil is returned
;; if selection was successful.
(defun gnus-group-read-ephemeral-group
- (group method &optional activate quit-config)
+ (group method &optional activate quit-config request-only)
+ "Read GROUP from METHOD as an ephemeral group.
+If ACTIVATE, request the group first.
+If QUIT-CONFIG, use that window configuration when
+exiting from the ephemeral group.
+If REQUEST-ONLY, don't actually read the group; just
+request it.
+
+Return the name of the group is selection was successful."
(let ((group (if (gnus-group-foreign-p group) group
(gnus-group-prefixed-name group method))))
(gnus-sethash
(cons (current-buffer) 'summary))))))
gnus-newsrc-hashtb)
(set-buffer gnus-group-buffer)
- (or (gnus-check-server method)
- (error "Unable to contact server: %s" (gnus-status-message method)))
- (if activate (or (gnus-request-group group)
- (error "Couldn't request group")))
- (condition-case ()
- (gnus-group-read-group t t group)
- (error nil)
- (quit nil))))
+ (unless (gnus-check-server method)
+ (error "Unable to contact server: %s" (gnus-status-message method)))
+ (when activate
+ (unless (gnus-request-group group)
+ (error "Couldn't request group")))
+ (if request-only
+ group
+ (condition-case ()
+ (when (gnus-group-read-group t t group)
+ group)
+ ;;(error nil)
+ (quit nil)))))
(defun gnus-group-jump-to-group (group)
"Jump to newsgroup GROUP."
;; Adjust cursor point.
(gnus-group-position-point)))
-(defun gnus-group-goto-group (group)
- "Goto to newsgroup GROUP."
+(defun gnus-group-goto-group (group &optional far)
+ "Goto to newsgroup GROUP.
+If FAR, it is likely that the group is not on the current line."
(when group
- ;; It's quite likely that we are on the right line, so
- ;; we check the current line first.
- (beginning-of-line)
- (if (eq (get-text-property (point) 'gnus-group)
+ (if far
+ (gnus-goto-char
+ (text-property-any
+ (point-min) (point-max)
+ 'gnus-group (gnus-intern-safe group gnus-active-hashtb)))
+ (beginning-of-line)
+ (cond
+ ;; It's quite likely that we are on the right line, so
+ ;; we check the current line first.
+ ((eq (get-text-property (point) 'gnus-group)
(gnus-intern-safe group gnus-active-hashtb))
- (point)
- ;; Search through the entire buffer.
- (let ((b (text-property-any
- (point-min) (point-max)
- 'gnus-group (gnus-intern-safe group gnus-active-hashtb))))
- (when b
- (goto-char b))))))
+ (point))
+ ;; Previous and next line are also likely, so we check them as well.
+ ((save-excursion
+ (forward-line -1)
+ (eq (get-text-property (point) 'gnus-group)
+ (gnus-intern-safe group gnus-active-hashtb)))
+ (forward-line -1)
+ (point))
+ ((save-excursion
+ (forward-line 1)
+ (eq (get-text-property (point) 'gnus-group)
+ (gnus-intern-safe group gnus-active-hashtb)))
+ (forward-line 1)
+ (point))
+ (t
+ ;; Search through the entire buffer.
+ (gnus-goto-char
+ (text-property-any
+ (point-min) (point-max)
+ 'gnus-group (gnus-intern-safe group gnus-active-hashtb))))))))
(defun gnus-group-next-group (n &optional silent)
"Go to next N'th newsgroup.
The user will be prompted for a NAME, for a select METHOD, and an
ADDRESS."
(interactive
- (cons
+ (list
(read-string "Group name: ")
- (let ((method
- (completing-read
- "Method: " (append gnus-valid-select-methods gnus-server-alist)
- nil t nil 'gnus-method-history)))
- (cond
- ((equal method "")
- (setq method gnus-select-method))
- ((assoc method gnus-valid-select-methods)
- (list method
- (if (memq 'prompt-address
- (assoc method gnus-valid-select-methods))
- (read-string "Address: ")
- "")))
- ((assoc method gnus-server-alist)
- (list method))
- (t
- (list method ""))))))
+ (gnus-read-method "From method: ")))
(let* ((meth (when (and method
(not (gnus-server-equal method gnus-select-method)))
(gnus-set-active nname (cons 1 0))
(or (gnus-ephemeral-group-p name)
(gnus-dribble-enter
- (concat "(gnus-group-set-info '" (prin1-to-string (cdr info)) ")")))
+ (concat "(gnus-group-set-info '"
+ (gnus-prin1-to-string (cdr info)) ")")))
;; Insert the line.
(gnus-group-insert-group-line-info nname)
(forward-line -1)
(gnus-group-position-point)))
(defun gnus-group-rename-group (group new-name)
+ "Rename group from GROUP to NEW-NAME.
+When used interactively, GROUP is the group under point
+and NEW-NAME will be prompted for."
(interactive
(list
(gnus-group-group-name)
(progn
- (or (gnus-check-backend-function
- 'request-rename-group (gnus-group-group-name))
- (error "This backend does not support renaming groups"))
- (read-string "New group name: "))))
-
- (or (gnus-check-backend-function 'request-rename-group group)
- (error "This backend does not support renaming groups"))
-
- (or group (error "No group to rename"))
- (and (string-match "^[ \t]*$" new-name)
- (error "Not a valid group name"))
+ (unless (gnus-check-backend-function
+ 'request-rename-group (gnus-group-group-name))
+ (error "This backend does not support renaming groups"))
+ (read-string "New group name: " (gnus-group-group-name)))))
+
+ (unless (gnus-check-backend-function 'request-rename-group group)
+ (error "This backend does not support renaming groups"))
+ (unless group
+ (error "No group to rename"))
+ (when (string-match "^[ \t]*$" new-name)
+ (error "Not a valid group name"))
+ (when (equal group new-name)
+ (error "Can't rename to the same name"))
;; We find the proper prefixed name.
(setq new-name
(defun gnus-group-edit-group (group &optional part)
"Edit the group on the current line."
(interactive (list (gnus-group-group-name)))
- (let* ((part (or part 'info))
- (done-func `(lambda ()
- "Exit editing mode and update the information."
- (interactive)
- (gnus-group-edit-group-done ',part ,group)))
- (winconf (current-window-configuration))
- info)
- (or group (error "No group on current line"))
- (or (setq info (gnus-get-info group))
- (error "Killed group; can't be edited"))
- (set-buffer (setq gnus-group-edit-buffer
- (get-buffer-create
- (format "*Gnus edit %s*" group))))
- (gnus-configure-windows 'edit-group)
- (gnus-add-current-to-buffer-list)
- (emacs-lisp-mode)
- ;; Suggested by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>.
- (use-local-map (copy-keymap emacs-lisp-mode-map))
- (local-set-key "\C-c\C-c" done-func)
- (make-local-variable 'gnus-prev-winconf)
- (setq gnus-prev-winconf winconf)
- (erase-buffer)
- (insert
- (cond
- ((eq part 'method)
- ";; Type `C-c C-c' after editing the select method.\n\n")
- ((eq part 'params)
- ";; Type `C-c C-c' after editing the group parameters.\n\n")
- ((eq part 'info)
- ";; Type `C-c C-c' after editing the group info.\n\n")))
- (insert
- (pp-to-string
- (cond ((eq part 'method)
- (or (gnus-info-method info) "native"))
- ((eq part 'params)
- (gnus-info-params info))
- (t info)))
- "\n")))
+ (let ((part (or part 'info))
+ info)
+ (unless group
+ (error "No group on current line"))
+ (unless (setq info (gnus-get-info group))
+ (error "Killed group; can't be edited"))
+ (gnus-edit-form
+ ;; Find the proper form to edit.
+ (cond ((eq part 'method)
+ (or (gnus-info-method info) "native"))
+ ((eq part 'params)
+ (gnus-info-params info))
+ (t info))
+ ;; The proper documentation.
+ (format
+ "Editing the %s."
+ (cond
+ ((eq part 'method) "select method")
+ ((eq part 'params) "group parameters")
+ (t "group info")))
+ `(lambda (form)
+ (gnus-group-edit-group-done ',part ,group form)))))
(defun gnus-group-edit-group-method (group)
"Edit the select method of GROUP."
(interactive (list (gnus-group-group-name)))
(gnus-group-edit-group group 'params))
-(defun gnus-group-edit-group-done (part group)
- "Get info from buffer, update variables and jump to the group buffer."
- (when (and gnus-group-edit-buffer
- (buffer-name gnus-group-edit-buffer))
- (set-buffer gnus-group-edit-buffer)
- (goto-char (point-min))
- (let* ((form (read (current-buffer)))
- (winconf gnus-prev-winconf)
- (method (cond ((eq part 'info) (nth 4 form))
- ((eq part 'method) form)
- (t nil)))
- (info (cond ((eq part 'info) form)
- ((eq part 'method) (gnus-get-info group))
+(defun gnus-group-edit-group-done (part group form)
+ "Update variables."
+ (let* ((method (cond ((eq part 'info) (nth 4 form))
+ ((eq part 'method) form)
(t nil)))
- (new-group (if info
- (if (or (not method)
- (gnus-server-equal
- gnus-select-method method))
- (gnus-group-real-name (car info))
- (gnus-group-prefixed-name
- (gnus-group-real-name (car info)) method))
- nil)))
- (when (and new-group
- (not (equal new-group group)))
- (when (gnus-group-goto-group group)
- (gnus-group-kill-group 1))
- (gnus-activate-group new-group))
- ;; Set the info.
- (if (and info new-group)
- (progn
- (setq info (gnus-copy-sequence info))
- (setcar info new-group)
- (unless (gnus-server-equal method "native")
- (unless (nthcdr 3 info)
- (nconc info (list nil nil)))
- (unless (nthcdr 4 info)
- (nconc info (list nil)))
- (gnus-info-set-method info method))
- (gnus-group-set-info info))
- (gnus-group-set-info form (or new-group group) part))
- (kill-buffer (current-buffer))
- (and winconf (set-window-configuration winconf))
- (set-buffer gnus-group-buffer)
- (gnus-group-update-group (or new-group group))
- (gnus-group-position-point))))
+ (info (cond ((eq part 'info) form)
+ ((eq part 'method) (gnus-get-info group))
+ (t nil)))
+ (new-group (if info
+ (if (or (not method)
+ (gnus-server-equal
+ gnus-select-method method))
+ (gnus-group-real-name (car info))
+ (gnus-group-prefixed-name
+ (gnus-group-real-name (car info)) method))
+ nil)))
+ (when (and new-group
+ (not (equal new-group group)))
+ (when (gnus-group-goto-group group)
+ (gnus-group-kill-group 1))
+ (gnus-activate-group new-group))
+ ;; Set the info.
+ (if (not (and info new-group))
+ (gnus-group-set-info form (or new-group group) part)
+ (setq info (gnus-copy-sequence info))
+ (setcar info new-group)
+ (unless (gnus-server-equal method "native")
+ (unless (nthcdr 3 info)
+ (nconc info (list nil nil)))
+ (unless (nthcdr 4 info)
+ (nconc info (list nil)))
+ (gnus-info-set-method info method))
+ (gnus-group-set-info info))
+ (gnus-group-update-group (or new-group group))
+ (gnus-group-position-point)))
(defun gnus-group-make-help-group ()
"Create the Gnus documentation group."
(file-name-nondirectory file) '(nndoc "")))))
(gnus-group-make-group
(gnus-group-real-name name)
- (list 'nndoc (file-name-nondirectory file)
+ (list 'nndoc file
(list 'nndoc-address file)
(list 'nndoc-article-type (or type 'guess))))))
+(defvar nnweb-type-definition)
+(defvar gnus-group-web-type-history nil)
+(defvar gnus-group-web-search-history nil)
+(defun gnus-group-make-web-group (&optional solid)
+ "Create an ephemeral nnweb group.
+If SOLID (the prefix), create a solid group."
+ (interactive "P")
+ (require 'nnweb)
+ (let* ((group
+ (if solid (read-string "Group name: ") (message-unique-id)))
+ (type
+ (completing-read
+ "Search engine type: "
+ (mapcar (lambda (elem) (list (symbol-name (car elem))))
+ nnweb-type-definition)
+ nil t (cons (or (car gnus-group-web-type-history)
+ (symbol-name (caar nnweb-type-definition)))
+ 0)
+ 'gnus-group-web-type-history))
+ (search
+ (read-string
+ "Search string: "
+ (cons (or (car gnus-group-web-search-history) "") 0)
+ 'gnus-group-web-search-history))
+ (method
+ `(nnweb ,group (nnweb-search ,search)
+ (nnweb-type ,(intern type)))))
+ (if solid
+ (gnus-group-make-group group method)
+ (gnus-group-read-ephemeral-group
+ group method t
+ (cons (current-buffer)
+ (if (eq major-mode 'gnus-summary-mode) 'summary 'group))))))
+
(defun gnus-group-make-archive-group (&optional all)
"Create the (ding) Gnus archive group of the most recent articles.
Given a prefix, create a full group."
(defun gnus-group-enter-directory (dir)
"Enter an ephemeral nneething group."
(interactive "DDirectory to read: ")
- (let* ((method (list 'nneething dir))
+ (let* ((method (list 'nneething dir '(nneething-read-only t)))
(leaf (gnus-group-prefixed-name
(file-name-nondirectory (directory-file-name dir))
method))
(name (gnus-generate-new-group-name leaf)))
- (let ((nneething-read-only t))
- (or (gnus-group-read-ephemeral-group
- name method t
- (cons (current-buffer) (if (eq major-mode 'gnus-summary-mode)
- 'summary 'group)))
- (error "Couldn't enter %s" dir)))))
+ (unless (gnus-group-read-ephemeral-group
+ name method t
+ (cons (current-buffer)
+ (if (eq major-mode 'gnus-summary-mode)
+ 'summary 'group)))
+ (error "Couldn't enter %s" dir))))
;; Group sorting commands
;; Suggested by Joe Hildebrand <hildjj@idaho.fuentez.com>.
"Sort alphabetically."
(string< (gnus-info-group info1) (gnus-info-group info2)))
+(defun gnus-group-sort-by-real-name (info1 info2)
+ "Sort alphabetically on real (unprefixed) names."
+ (string< (gnus-group-real-name (gnus-info-group info1))
+ (gnus-group-real-name (gnus-info-group info2))))
+
(defun gnus-group-sort-by-unread (info1 info2)
"Sort by number of unread articles."
(let ((n1 (car (gnus-gethash (gnus-info-group info1) gnus-newsrc-hashtb)))
(and (= level1 level2)
(> (gnus-info-score info1) (gnus-info-score info2))))))
-;; Group catching up.
+;;; Clearing data
(defun gnus-group-clear-data (n)
"Clear all marks and read ranges from the current group."
(let ((groups (gnus-group-process-prefix n))
group info)
(while (setq group (pop groups))
- (setq info (gnus-get-info group))
- (gnus-info-set-read info nil)
- (when (gnus-info-marks info)
- (gnus-info-set-marks info nil))
+ (gnus-info-clear-data (setq info (gnus-get-info group)))
(gnus-get-unread-articles-in-group info (gnus-active group) t)
(when (gnus-group-goto-group group)
(gnus-group-remove-mark group)
(gnus-group-update-group-line)))))
+(defun gnus-group-clear-data-on-native-groups ()
+ "Clear all marks and read ranges from all native groups."
+ (interactive)
+ (when (gnus-yes-or-no-p "Really clear all data from almost all groups? ")
+ (let ((alist (cdr gnus-newsrc-alist))
+ info)
+ (while (setq info (pop alist))
+ (gnus-info-clear-data info))
+ (gnus-get-unread-articles))))
+
+(defun gnus-info-clear-data (info)
+ "Clear all marks and read ranges from INFO."
+ (let ((group (gnus-info-group info)))
+ (gnus-undo-register
+ `(progn
+ (gnus-info-set-marks ,info ,(gnus-info-marks info))
+ (gnus-info-set-read ,info ,(gnus-info-read info))
+ (when (gnus-group-goto-group ,group)
+ (gnus-group-update-group-line))))
+ (gnus-info-set-read info nil)
+ (when (gnus-info-marks info)
+ (gnus-info-set-marks info nil))))
+
+;; Group catching up.
+
(defun gnus-group-catchup-current (&optional n all)
"Mark all articles not marked as unread in current newsgroup as read.
If prefix argument N is numeric, the ARG next newsgroups will be
(expirable (if (gnus-group-total-expirable-p group)
(cons nil (gnus-list-of-read-articles group))
(assq 'expire (gnus-info-marks info))))
- (expiry-wait (gnus-group-get-parameter group 'expiry-wait)))
+ (expiry-wait (gnus-group-find-parameter group 'expiry-wait)))
(when expirable
(setcdr
expirable
(gnus-delete-line)
(when (and (not discard)
(setq entry (gnus-gethash group gnus-newsrc-hashtb)))
+ (gnus-undo-register
+ `(progn
+ (gnus-group-goto-group ,(gnus-group-group-name))
+ (gnus-group-yank-group)))
(push (cons (car entry) (nth 2 entry))
gnus-list-of-killed-groups))
(gnus-group-change-level
info (gnus-info-level (cdr info)) gnus-level-killed
(and prev (gnus-gethash prev gnus-newsrc-hashtb))
t)
- (gnus-group-insert-group-line-info group))
+ (gnus-group-insert-group-line-info group)
+ (gnus-undo-register
+ `(when (gnus-group-goto-group ,group)
+ (gnus-group-kill-group 1))))
(forward-line -1)
(gnus-group-position-point)
(if (< (length out) 2) (car out) (nreverse out))))
group)
(while (setq group (pop groups))
(gnus-group-remove-mark group)
+ ;; Bypass any previous denials from the server.
+ (gnus-remove-denial (gnus-find-method-for-group group))
(if (gnus-activate-group group 'scan)
(progn
(gnus-get-unread-articles-in-group
(gnus-group-update-group group))
(if (eq (gnus-server-status (gnus-find-method-for-group group))
'denied)
- (gnus-error "Server denied access")
+ (gnus-error 3 "Server denied access")
(gnus-error 3 "%s error: %s" group (gnus-status-message group)))))
(when beg (goto-char beg))
(when gnus-goto-next-group-when-activating
ret))
(defun gnus-group-fetch-faq (group &optional faq-dir)
- "Fetch the FAQ for the current group."
+ "Fetch the FAQ for the current group.
+If given a prefix argument, prompt for the FAQ dir
+to use."
(interactive
(list
- (and (gnus-group-group-name)
- (gnus-group-real-name (gnus-group-group-name)))
+ (gnus-group-group-name)
(cond (current-prefix-arg
(completing-read
"Faq dir: " (and (listp gnus-group-faq-directory)
(mapcar (lambda (file) (list file))
gnus-group-faq-directory)))))))
- (or faq-dir
- (setq faq-dir (if (listp gnus-group-faq-directory)
- (car gnus-group-faq-directory)
- gnus-group-faq-directory)))
- (or group (error "No group name given"))
- (let ((file (concat (file-name-as-directory faq-dir)
- (gnus-group-real-name group))))
- (if (not (file-exists-p file))
- (error "No such file: %s" file)
- (find-file file))))
+ (unless group
+ (error "No group name given"))
+ (let ((dirs (or faq-dir gnus-group-faq-directory))
+ dir found file)
+ (unless (listp dirs)
+ (setq dirs (list dirs)))
+ (while (and (not found)
+ (setq dir (pop dirs)))
+ (setq file (concat (file-name-as-directory dir)
+ (gnus-group-real-name group)))
+ (if (not (file-exists-p file))
+ (gnus-message 1 "No such file: %s" file)
+ (find-file file)
+ (setq found t)))))
(defun gnus-group-describe-group (force &optional group)
"Display a description of the current newsgroup."
"Force Gnus to read the .newsrc file."
(interactive "P")
(when (gnus-yes-or-no-p
- (format "Are you sure you want to read %s? "
- gnus-current-startup-file))
+ (format "Are you sure you want to restart Gnus? "))
(gnus-save-newsrc-file)
(gnus-setup-news 'force)
(gnus-group-list-groups arg)))
(gnus-dribble-save)
(gnus-close-backends)
(gnus-clear-system)
+ (gnus-kill-buffer gnus-group-buffer)
;; Allow the user to do things after cleaning up.
(run-hooks 'gnus-after-exiting-gnus-hook)))
(defun gnus-group-set-params-info (group params)
(gnus-group-set-info params group 'params))
+(defun gnus-add-marked-articles (group type articles &optional info force)
+ ;; Add ARTICLES of TYPE to the info of GROUP.
+ ;; If INFO is non-nil, use that info. If FORCE is non-nil, don't
+ ;; add, but replace marked articles of TYPE with ARTICLES.
+ (let ((info (or info (gnus-get-info group)))
+ (uncompressed '(score bookmark killed))
+ marked m)
+ (or (not info)
+ (and (not (setq marked (nthcdr 3 info)))
+ (or (null articles)
+ (setcdr (nthcdr 2 info)
+ (list (list (cons type (gnus-compress-sequence
+ articles t)))))))
+ (and (not (setq m (assq type (car marked))))
+ (or (null articles)
+ (setcar marked
+ (cons (cons type (gnus-compress-sequence articles t) )
+ (car marked)))))
+ (if force
+ (if (null articles)
+ (setcar (nthcdr 3 info)
+ (delq (assq type (car marked)) (car marked)))
+ (setcdr m (gnus-compress-sequence articles t)))
+ (setcdr m (gnus-compress-sequence
+ (sort (nconc (gnus-uncompress-range (cdr m))
+ (copy-sequence articles)) '<) t))))))
+
+(defun gnus-update-read-articles (group unread)
+ "Update the list of read articles in GROUP."
+ (let* ((active (or gnus-newsgroup-active (gnus-active group)))
+ (entry (gnus-gethash group gnus-newsrc-hashtb))
+ (info (nth 2 entry))
+ (prev 1)
+ (unread (sort (copy-sequence unread) '<))
+ read)
+ (if (or (not info) (not active))
+ ;; There is no info on this group if it was, in fact,
+ ;; killed. Gnus stores no information on killed groups, so
+ ;; there's nothing to be done.
+ ;; One could store the information somewhere temporarily,
+ ;; perhaps... Hmmm...
+ ()
+ ;; Remove any negative articles numbers.
+ (while (and unread (< (car unread) 0))
+ (setq unread (cdr unread)))
+ ;; Remove any expired article numbers
+ (while (and unread (< (car unread) (car active)))
+ (setq unread (cdr unread)))
+ ;; Compute the ranges of read articles by looking at the list of
+ ;; unread articles.
+ (while unread
+ (if (/= (car unread) prev)
+ (setq read (cons (if (= prev (1- (car unread))) prev
+ (cons prev (1- (car unread)))) read)))
+ (setq prev (1+ (car unread)))
+ (setq unread (cdr unread)))
+ (when (<= prev (cdr active))
+ (setq read (cons (cons prev (cdr active)) read)))
+ (gnus-undo-register
+ `(progn
+ (gnus-info-set-marks ,info ,(gnus-info-marks info))
+ (gnus-info-set-read ,info ,(gnus-info-read info))
+ (gnus-get-unread-articles-in-group ,info (gnus-active ,group))))
+ ;; Enter this list into the group info.
+ (gnus-info-set-read
+ info (if (> (length read) 1) (nreverse read) read))
+ ;; Set the number of unread articles in gnus-newsrc-hashtb.
+ (gnus-get-unread-articles-in-group info (gnus-active group))
+ t)))
+
(provide 'gnus-group)
;;; gnus-group.el ends here
projects / gnus / blobdiff