comparison lisp/gnus/gnus-topic.el @ 85712:a3c27999decb

Update Gnus to No Gnus 0.7 from the Gnus CVS trunk Revision: [e-mail]/emacs--devo--0--patch-911

85711:b6f5dc84b2e1

;;; Utility functions

(defun gnus-group-topic-name ()
  "The name of the topic on the current line."
  (let ((topic (get-text-property (gnus-point-at-bol) 'gnus-topic)))
    (and topic (symbol-name topic))))

(defun gnus-group-topic-level ()
  "The level of the topic on the current line."
  (get-text-property (gnus-point-at-bol) 'gnus-topic-level))

(defun gnus-group-topic-unread ()
  "The number of unread articles in topic on the current line."
  (get-text-property (gnus-point-at-bol) 'gnus-topic-unread))

(defun gnus-topic-unread (topic)
  "Return the number of unread articles in TOPIC."
  (or (cdr (assoc topic gnus-topic-unreads))
      0))

  "Return non-nil if the current line is a topic."
  (gnus-group-topic-name))

(defun gnus-topic-visible-p ()
  "Return non-nil if the current topic is visible."
  (get-text-property (gnus-point-at-bol) 'gnus-topic-visible))

(defun gnus-topic-articles-in-topic (entries)
  (let ((total 0)
	number)
    (while entries

  "Go to TOPIC."
  (interactive
   (list (completing-read "Go to topic: "
			  (mapcar 'list (gnus-topic-list))
			  nil t)))
  (dolist (topic (gnus-current-topics topic))
    (gnus-topic-goto-topic topic)
    (gnus-topic-fold t))
  (gnus-topic-goto-topic topic))

(defun gnus-current-topic ()
  "Return the name of the current topic."
  (let ((result

      (setq topic (gnus-topic-parent-topic topic)))
    (nreverse topics)))

(defun gnus-group-active-topic-p ()
  "Say whether the current topic comes from the active topics."
  (save-excursion
    (beginning-of-line)
    (get-text-property (point) 'gnus-active)))

(defun gnus-topic-find-groups (topic &optional level all lowest recursive)
  "Return entries for all visible groups in TOPIC.
If RECURSIVE is t, return groups in its subtopics too."
  (let ((groups (cdr (assoc topic gnus-topic-alist)))

    (setq lowest (or lowest 1))
    (setq level (or level gnus-level-unsubscribed))
    ;; We go through the newsrc to look for matches.
    (while groups
      (when (setq group (pop groups))
	(setq entry (gnus-gethash group gnus-newsrc-hashtb)
	      info (nth 2 entry)
	      params (gnus-info-params info)
	      active (gnus-active group)
	      unread (or (car entry)
			 (and (not (equal group "dummy.group"))

       (push (or entry group) visible-groups)))
    (setq visible-groups (nreverse visible-groups))
    (when recursive
      (if (eq recursive t)
	  (setq recursive (cdr (gnus-topic-find-topology topic))))
      (mapcar (lambda (topic-topology)
		(setq visible-groups
		      (nconc visible-groups
			     (gnus-topic-find-groups
			      (caar topic-topology)
			      level all lowest topic-topology))))
	      (cdr recursive)))
    visible-groups))

(defun gnus-topic-goto-previous-topic (n)
  "Go to the N'th previous topic."
  (interactive "p")

  "Return a list of all topics in the topology."
  (unless topology
    (setq topology gnus-topic-topology
	  gnus-tmp-topics nil))
  (push (caar topology) gnus-tmp-topics)
  (mapcar 'gnus-topic-list (cdr topology))
  gnus-tmp-topics)

;;; Topic parameter jazz

(defun gnus-topic-parameters (topic)

    (setcar (nthcdr 3 (cadr top)) parameters)
    (gnus-dribble-enter
     (format "(gnus-topic-set-parameters %S '%S)" topic parameters))))

(defun gnus-group-topic-parameters (group)
  "Compute the group parameters for GROUP taking into account inheritance from topics."
  (let ((params-list (copy-sequence (gnus-group-get-parameter group))))
    (save-excursion
      (nconc params-list
	     (gnus-topic-hierarchical-parameters
	      ;; First we try to go to the group within the group
	      ;; buffer and find the topic for the group that way.
	      ;; This hopefully copes well with groups that are in
	      ;; more than one topic.  Failing that (i.e. when the
	      ;; group isn't visible in the group buffer) we find a
	      ;; topic for the group via gnus-group-topic.
	      (or (and (gnus-group-goto-group group)
		       (gnus-current-topic))
		  (gnus-group-topic group)))))))

(defun gnus-topic-hierarchical-parameters (topic)
  "Return a topic list computed for TOPIC."
  (let ((topics (gnus-current-topics topic))
	params-list param out params)
    (while topics
      (push (gnus-topic-parameters (pop topics)) params-list))
    ;; We probably have lots of nil elements here, so
    ;; we remove them.  Probably faster than doing this "properly".
    (setq params-list (delq nil params-list))
    ;; Now we have all the parameters, so we go through them
    ;; and do inheritance in the obvious way.
    (while (setq params (pop params-list))
      (while (setq param (pop params))
	(when (atom param)
	  (setq param (cons param t)))
	;; Override any old versions of this param.
	(gnus-pull (car param) out)
	(push param out)))
    ;; Return the resulting parameter list.
    out))

;;; General utility functions

      (when not-in-list
	(unless gnus-killed-hashtb
	  (gnus-make-hashtable-from-killed))
	(gnus-group-prepare-flat-list-dead
	 (gnus-remove-if (lambda (group)
			   (or (gnus-gethash group gnus-newsrc-hashtb)
			       (gnus-gethash group gnus-killed-hashtb)))
			 not-in-list)
	 gnus-level-killed ?K regexp)))

    ;; Use topics.

		 (gnus-topic-parent-topic topic))))
    (when (and parent
	       (not (gnus-topic-goto-missing-topic (caadr parent))))
      (gnus-topic-display-missing-topic (caadr parent))))
  (gnus-topic-goto-missing-topic topic)
  (let* ((top (gnus-topic-find-topology topic))
	 (children (cddr top))
	 (type (cadr top))
	 (unread 0)
	 (entries (gnus-topic-find-groups

      (unless (assoc (car topics) gnus-topic-alist)
	(push (list (car topics)) gnus-topic-alist))
      (pop topics)))
  ;; Go through all living groups and make sure that
  ;; they belong to some topic.
  (let* ((tgroups (apply 'append (mapcar (lambda (entry) (cdr entry))
					 gnus-topic-alist)))
	 (entry (last (assoc (caar gnus-topic-topology) gnus-topic-alist)))
	 (newsrc (cdr gnus-newsrc-alist))
	 group)
    (while newsrc
      (unless (member (setq group (gnus-info-group (pop newsrc))) tgroups)

  (let ((alist gnus-topic-alist)
	topic)
    (while (setq topic (pop alist))
      (while (cdr topic)
	(if (and (cadr topic)
		 (gnus-gethash (cadr topic) gnus-newsrc-hashtb))
	    (setq topic (cdr topic))
	  (setcdr topic (cddr topic)))))))

(defun gnus-topic-init-alist ()
  "Initialize the topic structures."

      (gnus-make-hashtable-from-killed))
    (while (setq topic (pop topic-alist))
      (let ((topic-name (pop topic))
	    group filtered-topic)
	(while (setq group (pop topic))
	  (when (and (or (gnus-gethash group gnus-active-hashtb)
			 (gnus-info-method (gnus-get-info group)))
		     (not (gnus-gethash group gnus-killed-hashtb)))
	    (push group filtered-topic)))
	(push (cons topic-name (nreverse filtered-topic)) result)))
    (setq gnus-topic-alist (nreverse result))))

    (if (not gnus-topic-mode)
	(setq gnus-goto-missing-group-function nil)
      (when (gnus-visual-p 'topic-menu 'menu)
	(gnus-topic-make-menu-bar))
      (gnus-set-format 'topic t)
      (gnus-add-minor-mode 'gnus-topic-mode " Topic" gnus-topic-mode-map)
      (add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic)
      (set (make-local-variable 'gnus-group-prepare-function)
	   'gnus-group-prepare-topics)
      (set (make-local-variable 'gnus-group-get-parameter-function)
	   'gnus-group-topic-parameters)

	(start-topic (gnus-group-topic-name))
	(start-group (progn (forward-line 1) (gnus-group-group-name)))
	entry)
    (if (and (not groups) (not copyp) start-topic)
	(gnus-topic-move start-topic topic)
      (mapcar
       (lambda (g)
	 (gnus-group-remove-mark g use-marked)
	 (when (and
		(setq entry (assoc (gnus-current-topic) gnus-topic-alist))
		(not copyp))
	   (setcdr entry (gnus-delete-first g (cdr entry))))
	 (nconc topicl (list g)))
       groups)
      (gnus-topic-enter-dribble)
      (if start-group
	  (gnus-group-goto-group start-group)
	(gnus-topic-goto-topic start-topic))
      (gnus-group-list-groups))))

  "Remove the current group from the topic."
  (interactive "P")
  (let ((use-marked (and (not n) (not (gnus-region-active-p))
			 gnus-group-marked t))
	(groups (gnus-group-process-prefix n)))
    (mapcar
     (lambda (group)
       (gnus-group-remove-mark group use-marked)
       (let ((topicl (assoc (gnus-current-topic) gnus-topic-alist))
	     (buffer-read-only nil))
	 (when (and topicl group)

    (unless to-top
      (error "Can't find topic `%s'" to))
    (if (gnus-topic-find-topology to current-top 0);; Don't care the level
	(error "Can't move `%s' to its sub-level" current))
    (gnus-topic-find-topology current nil nil 'delete)
    (while (cdr to-top)
      (setq to-top (cdr to-top)))
    (setcdr to-top (list current-top))
    (gnus-topic-enter-dribble)
    (gnus-group-list-groups)
    (gnus-topic-goto-topic current)))

(defun gnus-subscribe-topics (newsgroup)

85712:a3c27999decb

;;; Utility functions

(defun gnus-group-topic-name ()
  "The name of the topic on the current line."
  (let ((topic (get-text-property (point-at-bol) 'gnus-topic)))
    (and topic (symbol-name topic))))

(defun gnus-group-topic-level ()
  "The level of the topic on the current line."
  (get-text-property (point-at-bol) 'gnus-topic-level))

(defun gnus-group-topic-unread ()
  "The number of unread articles in topic on the current line."
  (get-text-property (point-at-bol) 'gnus-topic-unread))

(defun gnus-topic-unread (topic)
  "Return the number of unread articles in TOPIC."
  (or (cdr (assoc topic gnus-topic-unreads))
      0))

  "Return non-nil if the current line is a topic."
  (gnus-group-topic-name))

(defun gnus-topic-visible-p ()
  "Return non-nil if the current topic is visible."
  (get-text-property (point-at-bol) 'gnus-topic-visible))

(defun gnus-topic-articles-in-topic (entries)
  (let ((total 0)
	number)
    (while entries

  "Go to TOPIC."
  (interactive
   (list (completing-read "Go to topic: "
			  (mapcar 'list (gnus-topic-list))
			  nil t)))
  (let ((buffer-read-only nil))
    (dolist (topic (gnus-current-topics topic))
      (unless (gnus-topic-goto-topic topic)
	(gnus-topic-goto-missing-topic topic)
	(gnus-topic-display-missing-topic topic))))
  (gnus-topic-goto-topic topic))

(defun gnus-current-topic ()
  "Return the name of the current topic."
  (let ((result

      (setq topic (gnus-topic-parent-topic topic)))
    (nreverse topics)))

(defun gnus-group-active-topic-p ()
  "Say whether the current topic comes from the active topics."
  (get-text-property (point-at-bol) 'gnus-active))

(defun gnus-topic-find-groups (topic &optional level all lowest recursive)
  "Return entries for all visible groups in TOPIC.
If RECURSIVE is t, return groups in its subtopics too."
  (let ((groups (cdr (assoc topic gnus-topic-alist)))

    (setq lowest (or lowest 1))
    (setq level (or level gnus-level-unsubscribed))
    ;; We go through the newsrc to look for matches.
    (while groups
      (when (setq group (pop groups))
	(setq entry (gnus-group-entry group)
	      info (nth 2 entry)
	      params (gnus-info-params info)
	      active (gnus-active group)
	      unread (or (car entry)
			 (and (not (equal group "dummy.group"))

       (push (or entry group) visible-groups)))
    (setq visible-groups (nreverse visible-groups))
    (when recursive
      (if (eq recursive t)
	  (setq recursive (cdr (gnus-topic-find-topology topic))))
      (dolist (topic-topology (cdr recursive))
	(setq visible-groups
	      (nconc visible-groups
		     (gnus-topic-find-groups
		      (caar topic-topology)
		      level all lowest topic-topology)))))
    visible-groups))

(defun gnus-topic-goto-previous-topic (n)
  "Go to the N'th previous topic."
  (interactive "p")

  "Return a list of all topics in the topology."
  (unless topology
    (setq topology gnus-topic-topology
	  gnus-tmp-topics nil))
  (push (caar topology) gnus-tmp-topics)
  (mapc 'gnus-topic-list (cdr topology))
  gnus-tmp-topics)

;;; Topic parameter jazz

(defun gnus-topic-parameters (topic)

    (setcar (nthcdr 3 (cadr top)) parameters)
    (gnus-dribble-enter
     (format "(gnus-topic-set-parameters %S '%S)" topic parameters))))

(defun gnus-group-topic-parameters (group)
  "Compute the group parameters for GROUP in topic mode.
Possibly inherit parameters from topics above GROUP."
  (let ((params-list (copy-sequence (gnus-group-get-parameter group))))
    (save-excursion
      (gnus-topic-hierarchical-parameters
       ;; First we try to go to the group within the group buffer and find the
       ;; topic for the group that way. This hopefully copes well with groups
       ;; that are in more than one topic. Failing that (i.e. when the group
       ;; isn't visible in the group buffer) we find a topic for the group via
       ;; gnus-group-topic.
       (or (and (gnus-group-goto-group group)
		(gnus-current-topic))
	   (gnus-group-topic group))
       params-list))))

(defun gnus-topic-hierarchical-parameters (topic &optional group-params-list)
  "Compute the topic parameters for TOPIC.
Possibly inherit parameters from topics above TOPIC.
If optional argument GROUP-PARAMS-LIST is non-nil, use it as the basis for
inheritance."
  (let ((params-list
	 ;; We probably have lots of nil elements here, so we remove them.
	 ;; Probably faster than doing this "properly".
	 (delq nil (cons group-params-list
			 (mapcar 'gnus-topic-parameters
				 (gnus-current-topics topic)))))
	param out params)
    ;; Now we have all the parameters, so we go through them
    ;; and do inheritance in the obvious way.
    (let (posting-style)
      (while (setq params (pop params-list))
	(while (setq param (pop params))
	  (when (atom param)
	    (setq param (cons param t)))
	  (cond ((eq (car param) 'posting-style)
		 (let ((param (cdr param))
		       elt)
		   (while (setq elt (pop param))
		     (unless (assoc (car elt) posting-style)
		       (push elt posting-style)))))
		(t
		 (unless (assq (car param) out)
		   (push param out))))))
      (and posting-style (push (cons 'posting-style posting-style) out)))
    ;; Return the resulting parameter list.
    out))

;;; General utility functions

      (when not-in-list
	(unless gnus-killed-hashtb
	  (gnus-make-hashtable-from-killed))
	(gnus-group-prepare-flat-list-dead
	 (gnus-remove-if (lambda (group)
			   (or (gnus-group-entry group)
			       (gnus-gethash group gnus-killed-hashtb)))
			 not-in-list)
	 gnus-level-killed ?K regexp)))

    ;; Use topics.

		 (gnus-topic-parent-topic topic))))
    (when (and parent
	       (not (gnus-topic-goto-missing-topic (caadr parent))))
      (gnus-topic-display-missing-topic (caadr parent))))
  (gnus-topic-goto-missing-topic topic)
  ;; Skip past all groups in the topic we're in.
  (while (gnus-group-group-name)
    (forward-line 1))
  (let* ((top (gnus-topic-find-topology topic))
	 (children (cddr top))
	 (type (cadr top))
	 (unread 0)
	 (entries (gnus-topic-find-groups

      (unless (assoc (car topics) gnus-topic-alist)
	(push (list (car topics)) gnus-topic-alist))
      (pop topics)))
  ;; Go through all living groups and make sure that
  ;; they belong to some topic.
  (let* ((tgroups (apply 'append (mapcar 'cdr gnus-topic-alist)))
	 (entry (last (assoc (caar gnus-topic-topology) gnus-topic-alist)))
	 (newsrc (cdr gnus-newsrc-alist))
	 group)
    (while newsrc
      (unless (member (setq group (gnus-info-group (pop newsrc))) tgroups)

  (let ((alist gnus-topic-alist)
	topic)
    (while (setq topic (pop alist))
      (while (cdr topic)
	(if (and (cadr topic)
		 (gnus-group-entry (cadr topic)))
	    (setq topic (cdr topic))
	  (setcdr topic (cddr topic)))))))

(defun gnus-topic-init-alist ()
  "Initialize the topic structures."

      (gnus-make-hashtable-from-killed))
    (while (setq topic (pop topic-alist))
      (let ((topic-name (pop topic))
	    group filtered-topic)
	(while (setq group (pop topic))
	  (when (and (or (gnus-active group)
			 (gnus-info-method (gnus-get-info group)))
		     (not (gnus-gethash group gnus-killed-hashtb)))
	    (push group filtered-topic)))
	(push (cons topic-name (nreverse filtered-topic)) result)))
    (setq gnus-topic-alist (nreverse result))))

    (if (not gnus-topic-mode)
	(setq gnus-goto-missing-group-function nil)
      (when (gnus-visual-p 'topic-menu 'menu)
	(gnus-topic-make-menu-bar))
      (gnus-set-format 'topic t)
      (add-minor-mode 'gnus-topic-mode " Topic" gnus-topic-mode-map)
      (add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic)
      (set (make-local-variable 'gnus-group-prepare-function)
	   'gnus-group-prepare-topics)
      (set (make-local-variable 'gnus-group-get-parameter-function)
	   'gnus-group-topic-parameters)

	(start-topic (gnus-group-topic-name))
	(start-group (progn (forward-line 1) (gnus-group-group-name)))
	entry)
    (if (and (not groups) (not copyp) start-topic)
	(gnus-topic-move start-topic topic)
      (dolist (g groups)
	(gnus-group-remove-mark g use-marked)
	(when (and
	       (setq entry (assoc (gnus-current-topic) gnus-topic-alist))
	       (not copyp))
	  (setcdr entry (gnus-delete-first g (cdr entry))))
	(nconc topicl (list g)))
      (gnus-topic-enter-dribble)
      (if start-group
	  (gnus-group-goto-group start-group)
	(gnus-topic-goto-topic start-topic))
      (gnus-group-list-groups))))

  "Remove the current group from the topic."
  (interactive "P")
  (let ((use-marked (and (not n) (not (gnus-region-active-p))
			 gnus-group-marked t))
	(groups (gnus-group-process-prefix n)))
    (mapc
     (lambda (group)
       (gnus-group-remove-mark group use-marked)
       (let ((topicl (assoc (gnus-current-topic) gnus-topic-alist))
	     (buffer-read-only nil))
	 (when (and topicl group)

    (unless to-top
      (error "Can't find topic `%s'" to))
    (if (gnus-topic-find-topology to current-top 0);; Don't care the level
	(error "Can't move `%s' to its sub-level" current))
    (gnus-topic-find-topology current nil nil 'delete)
    (setcdr (last to-top) (list current-top))
    (gnus-topic-enter-dribble)
    (gnus-group-list-groups)
    (gnus-topic-goto-topic current)))

(defun gnus-subscribe-topics (newsgroup)