/[emacs]/emacs/lisp/gnus/gnus-topic.el
ViewVC logotype

Diff of /emacs/lisp/gnus/gnus-topic.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.8 by zsh, Sun Dec 24 06:36:33 2000 UTC revision 1.8.18.1 by miles, Fri Apr 4 06:20:21 2003 UTC
# Line 163  with some simple extensions. Line 163  with some simple extensions.
163    (dolist (topic (gnus-current-topics topic))    (dolist (topic (gnus-current-topics topic))
164      (gnus-topic-fold t))      (gnus-topic-fold t))
165    (gnus-topic-goto-topic topic))    (gnus-topic-goto-topic topic))
166      
167  (defun gnus-current-topic ()  (defun gnus-current-topic ()
168    "Return the name of the current topic."    "Return the name of the current topic."
169    (let ((result    (let ((result
# Line 233  If RECURSIVE is t, return groups in its Line 233  If RECURSIVE is t, return groups in its
233         ;; Add this group to the list of visible groups.         ;; Add this group to the list of visible groups.
234         (push (or entry group) visible-groups)))         (push (or entry group) visible-groups)))
235      (setq visible-groups (nreverse visible-groups))      (setq visible-groups (nreverse visible-groups))
236      (when recursive      (when recursive
237        (if (eq recursive t)        (if (eq recursive t)
238            (setq recursive (cdr (gnus-topic-find-topology topic))))            (setq recursive (cdr (gnus-topic-find-topology topic))))
239        (mapcar (lambda (topic-topology)        (mapcar (lambda (topic-topology)
240                  (setq visible-groups                  (setq visible-groups
241                        (nconc visible-groups                        (nconc visible-groups
242                               (gnus-topic-find-groups                               (gnus-topic-find-groups
243                                (caar topic-topology)                                (caar topic-topology)
244                                level all lowest topic-topology))))                                level all lowest topic-topology))))
245                (cdr recursive)))                (cdr recursive)))
246      visible-groups))      visible-groups))
# Line 1146  When used interactively, PARENT will be Line 1146  When used interactively, PARENT will be
1146    (gnus-group-list-groups)    (gnus-group-list-groups)
1147    (gnus-topic-goto-topic topic))    (gnus-topic-goto-topic topic))
1148    
1149  ;; FIXME:  ;; FIXME:
1150  ;;  1. When the marked groups are overlapped with the process  ;;  1. When the marked groups are overlapped with the process
1151  ;;     region, the behavior of move or remove is not right.  ;;     region, the behavior of move or remove is not right.
1152  ;;  2. Can't process on several marked groups with a same name,  ;;  2. Can't process on several marked groups with a same name,
1153  ;;     because gnus-group-marked only keeps one copy.  ;;     because gnus-group-marked only keeps one copy.
1154    
1155  (defun gnus-topic-move-group (n topic &optional copyp)  (defun gnus-topic-move-group (n topic &optional copyp)
# Line 1158  If COPYP, copy the groups instead." Line 1158  If COPYP, copy the groups instead."
1158    (interactive    (interactive
1159     (list current-prefix-arg     (list current-prefix-arg
1160           (completing-read "Move to topic: " gnus-topic-alist nil t)))           (completing-read "Move to topic: " gnus-topic-alist nil t)))
1161    (let ((use-marked (and (not n) (not (gnus-region-active-p))    (let ((use-marked (and (not n) (not (gnus-region-active-p))
1162                           gnus-group-marked t))                           gnus-group-marked t))
1163          (groups (gnus-group-process-prefix n))          (groups (gnus-group-process-prefix n))
1164          (topicl (assoc topic gnus-topic-alist))          (topicl (assoc topic gnus-topic-alist))
# Line 1185  If COPYP, copy the groups instead." Line 1185  If COPYP, copy the groups instead."
1185  (defun gnus-topic-remove-group (&optional n)  (defun gnus-topic-remove-group (&optional n)
1186    "Remove the current group from the topic."    "Remove the current group from the topic."
1187    (interactive "P")    (interactive "P")
1188    (let ((use-marked (and (not n) (not (gnus-region-active-p))    (let ((use-marked (and (not n) (not (gnus-region-active-p))
1189                           gnus-group-marked t))                           gnus-group-marked t))
1190          (groups (gnus-group-process-prefix n)))          (groups (gnus-group-process-prefix n)))
1191      (mapcar      (mapcar
# Line 1283  If PERMANENT, make it stay hidden in sub Line 1283  If PERMANENT, make it stay hidden in sub
1283    (when (gnus-current-topic)    (when (gnus-current-topic)
1284      (gnus-topic-goto-topic (gnus-current-topic))      (gnus-topic-goto-topic (gnus-current-topic))
1285      (if permanent      (if permanent
1286          (setcar (cddr          (setcar (cddr
1287                   (cadr                   (cadr
1288                    (gnus-topic-find-topology (gnus-current-topic))))                    (gnus-topic-find-topology (gnus-current-topic))))
1289                  'hidden))                  'hidden))
# Line 1296  If PERMANENT, make it stay shown in subs Line 1296  If PERMANENT, make it stay shown in subs
1296    (when (gnus-group-topic-p)    (when (gnus-group-topic-p)
1297      (if (not permanent)      (if (not permanent)
1298          (gnus-topic-remove-topic t nil)          (gnus-topic-remove-topic t nil)
1299        (let ((topic        (let ((topic
1300               (gnus-topic-find-topology               (gnus-topic-find-topology
1301                (completing-read "Show topic: " gnus-topic-alist nil t))))                (completing-read "Show topic: " gnus-topic-alist nil t))))
1302          (setcar (cddr (cadr topic)) nil)          (setcar (cddr (cadr topic)) nil)
1303          (setcar (cdr (cadr topic)) 'visible)          (setcar (cdr (cadr topic)) 'visible)
# Line 1312  If RECURSIVE is t, mark its subtopics to Line 1312  If RECURSIVE is t, mark its subtopics to
1312    (if (not topic)    (if (not topic)
1313        (call-interactively 'gnus-group-mark-group)        (call-interactively 'gnus-group-mark-group)
1314      (save-excursion      (save-excursion
1315        (let ((groups (gnus-topic-find-groups topic gnus-level-killed t nil        (let ((groups (gnus-topic-find-groups topic gnus-level-killed t nil
1316                                              recursive)))                                              recursive)))
1317          (while groups          (while groups
1318            (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark)            (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark)
# Line 1416  If UNINDENT, remove an indentation." Line 1416  If UNINDENT, remove an indentation."
1416          (gnus-topic-kill-group)          (gnus-topic-kill-group)
1417          (push (cdar gnus-topic-killed-topics) gnus-topic-alist)          (push (cdar gnus-topic-killed-topics) gnus-topic-alist)
1418          (gnus-topic-create-topic          (gnus-topic-create-topic
1419           topic parent nil (cdaar gnus-topic-killed-topics))           topic parent nil (cdar (car gnus-topic-killed-topics)))
1420          (pop gnus-topic-killed-topics)          (pop gnus-topic-killed-topics)
1421          (or (gnus-topic-goto-topic topic)          (or (gnus-topic-goto-topic topic)
1422              (gnus-topic-goto-topic parent))))))              (gnus-topic-goto-topic parent))))))
# Line 1435  If UNINDENT, remove an indentation." Line 1435  If UNINDENT, remove an indentation."
1435        (push (cdar gnus-topic-killed-topics) gnus-topic-alist)        (push (cdar gnus-topic-killed-topics) gnus-topic-alist)
1436        (gnus-topic-create-topic        (gnus-topic-create-topic
1437         topic grandparent (gnus-topic-next-topic parent)         topic grandparent (gnus-topic-next-topic parent)
1438         (cdaar gnus-topic-killed-topics))         (cdar (car gnus-topic-killed-topics)))
1439        (pop gnus-topic-killed-topics)        (pop gnus-topic-killed-topics)
1440        (gnus-topic-goto-topic topic))))        (gnus-topic-goto-topic topic))))
1441    
# Line 1558  If REVERSE, sort in reverse order." Line 1558  If REVERSE, sort in reverse order."
1558               (mapcar `(lambda (top)               (mapcar `(lambda (top)
1559                          (gnus-topic-sort-topics-1 top ,reverse))                          (gnus-topic-sort-topics-1 top ,reverse))
1560                       (sort (cdr top)                       (sort (cdr top)
1561                             '(lambda (t1 t2)                             '(lambda (t1 t2)
1562                                (string-lessp (caar t1) (caar t2)))))))                                (string-lessp (caar t1) (caar t2)))))))
1563          (setcdr top (if reverse (reverse subtop) subtop))))          (setcdr top (if reverse (reverse subtop) subtop))))
1564    top)    top)
1565    
1566  (defun gnus-topic-sort-topics (&optional topic reverse)  (defun gnus-topic-sort-topics (&optional topic reverse)
1567    "Sort topics in TOPIC alphabeticaly by topic name.    "Sort topics in TOPIC alphabetically by topic name.
1568  If REVERSE, reverse the sorting order."  If REVERSE, reverse the sorting order."
1569    (interactive    (interactive
1570     (list (completing-read "Sort topics in : " gnus-topic-alist nil t     (list (completing-read "Sort topics in : " gnus-topic-alist nil t
1571                            (gnus-current-topic))                            (gnus-current-topic))
1572           current-prefix-arg))           current-prefix-arg))
1573    (let ((topic-topology (or (and topic (cdr (gnus-topic-find-topology topic)))    (let ((topic-topology (or (and topic (cdr (gnus-topic-find-topology topic)))
# Line 1579  If REVERSE, reverse the sorting order." Line 1579  If REVERSE, reverse the sorting order."
1579    
1580  (defun gnus-topic-move (current to)  (defun gnus-topic-move (current to)
1581    "Move the CURRENT topic to TO."    "Move the CURRENT topic to TO."
1582    (interactive    (interactive
1583     (list     (list
1584      (gnus-group-topic-name)      (gnus-group-topic-name)
1585      (completing-read "Move to topic: " gnus-topic-alist nil t)))      (completing-read "Move to topic: " gnus-topic-alist nil t)))
1586    (unless (and current to)    (unless (and current to)
# Line 1613  If REVERSE, reverse the sorting order." Line 1613  If REVERSE, reverse the sorting order."
1613            ;; Add the group to the topic.            ;; Add the group to the topic.
1614            (nconc (assoc topic gnus-topic-alist) (list newsgroup))            (nconc (assoc topic gnus-topic-alist) (list newsgroup))
1615            (throw 'end t))))))            (throw 'end t))))))
1616              
1617  (provide 'gnus-topic)  (provide 'gnus-topic)
1618    
1619  ;;; gnus-topic.el ends here  ;;; gnus-topic.el ends here

Legend:
Removed from v.1.8  
changed lines
  Added in v.1.8.18.1

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26