X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/c860062c7be598c8ba40e47fed4e3272945329dd..368dbd026fe0ebd0f9f50be09d0f2a5f58d06c0a:/packages/debbugs/debbugs-gnu.el

diff --git a/packages/debbugs/debbugs-gnu.el b/packages/debbugs/debbugs-gnu.el
index 1115db819..a46d99ef4 100644
--- a/packages/debbugs/debbugs-gnu.el
+++ b/packages/debbugs/debbugs-gnu.el
@@ -1,6 +1,6 @@
 ;;; debbugs-gnu.el --- interface for the GNU bug tracker
 
-;; Copyright (C) 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2011, 2012 Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Keywords: comm, hypermedia, maint
@@ -30,10 +30,11 @@
 ;; also for other GNU projects which use the same bug tracker.
 
 ;; If you have `debbugs-gnu.el' in your load-path, you could enable
-;; the bug tracker command by the following lines in your ~/.emacs
+;; the bug tracker commands by the following lines in your ~/.emacs
 ;;
 ;;   (autoload 'debbugs-gnu "debbugs-gnu" "" 'interactive)
 ;;   (autoload 'debbugs-gnu-search "debbugs-gnu" "" 'interactive)
+;;   (autoload 'debbugs-gnu-usertags "debbugs-gnu" "" 'interactive)
 
 ;; The bug tracker is called interactively by
 ;;
@@ -46,8 +47,12 @@
 ;; used, although configured on the GNU bug tracker.  If no severity
 ;; is given, all bugs are selected.
 
-;; There is also the pseudo severity "tagged", which selects locally
-;; tagged bugs.
+;; There is also the pseudo severity "tagged".  When it is used, the
+;; function will ask for user tags (a comma separated list), and shows
+;; just the bugs which are tagged with them.  In general, user tags
+;; shall be strings denoting to subprojects of the package, like
+;; "cedet" or "tramp" of the package "emacs.  If no user tag is given,
+;; locally tagged bugs are shown.
 
 ;; If a prefix is given to the command, more search parameters are
 ;; asked for, like packages (also a comma separated list, "emacs" is
@@ -76,7 +81,7 @@
 ;; `debbugs-gnu-default-severities', `debbugs-gnu-default-packages',
 ;; `debbugs-gnu-default-hits-per-page' and `debbugs-gnu-default-suppress-bugs'.
 
-;; The command creates one or more pages of bug lists.  Every bug is
+;; The commands create one or more pages of bug lists.  Every bug is
 ;; shown in one line, including the bug number, the status (combining
 ;; merged bug numbers, keywords and severities), the name of the
 ;; submitter, and the title of the bug.  On every bug line you could
@@ -93,6 +98,8 @@
 ;;   "q": Quit the buffer
 ;;   "s": Toggle bug sorting for age or for state
 ;;   "x": Toggle suppressing of bugs
+;;   "/": Display only bugs matching a string
+;;   "w": Display all the currently selected bug reports
 
 ;; When you visit the related bug messages in Gnus, you could also
 ;; send control messages by keystroke "C".
@@ -102,6 +109,22 @@
 ;; happens as expected for the respective column; sorting in the Title
 ;; column is depending on whether you are the owner of a bug.
 
+;; Another approach for listing bugs is calling the command
+;;
+;;   M-x debbugs-gnu-usertags
+
+;; This command shows you all existing user tags for the packages
+;; defined in `debbugs-gnu-default-packages'.  A prefix for the
+;; command allows you to use other packe names, or an arbitrary string
+;; for a user who has tagged bugs.  The command returns the list of
+;; existing user tags for the given user(s) or package name(s),
+;; respectively.  Applying RET on a user tag, all bugs tagged with
+;; this user tag are shown.
+
+;; Unfortunately, it is not possible with the SOAP interface to show
+;; all users who have tagged bugs.  This list can be retrieved via
+;; <http://debbugs.gnu.org/cgi/pkgindex.cgi?indexon=users>.
+
 ;;; Code:
 
 (require 'debbugs)
@@ -120,9 +143,10 @@
   :group 'debbugs
   :version "24.1")
 
-(defcustom debbugs-gnu-default-severities '("normal")
+(defcustom debbugs-gnu-default-severities '("serious" "important" "normal")
   "*The list severities bugs are searched for.
 \"tagged\" is not a severity but marks locally tagged bugs."
+  ;; <http://debbugs.gnu.org/Developer.html#severities>
   :group 'debbugs-gnu
   :type '(set (const "serious")
 	      (const "important")
@@ -132,16 +156,30 @@
 	      (const "tagged"))
   :version "24.1")
 
+(defconst debbugs-gnu-all-severities
+  (mapcar 'cadr (cdr (get 'debbugs-gnu-default-severities 'custom-type)))
+  "*List of all possible severities.")
+
 (defcustom debbugs-gnu-default-packages '("emacs")
   "*The list of packages to be searched for."
+  ;; <http://debbugs.gnu.org/Packages.html>
   :group 'debbugs-gnu
   :type '(set (const "automake")
 	      (const "coreutils")
+	      (const "debbugs.gnu.org")
 	      (const "emacs")
+	      (const "emacs-xwidgets")
+	      (const "fm")
 	      (const "gnus")
-	      (const "libtool"))
+	      (const "guile")
+	      (const "libtool")
+	      (const "woodchuck"))
   :version "24.1")
 
+(defconst debbugs-gnu-all-packages
+  (mapcar 'cadr (cdr (get 'debbugs-gnu-default-packages 'custom-type)))
+  "*List of all possible package names.")
+
 (defcustom debbugs-gnu-default-hits-per-page 500
   "*The number of bugs shown per page."
   :group 'debbugs-gnu
@@ -272,20 +310,15 @@ marked as \"client-side filter\"."
 	      (setq
 	       severities
 	       (completing-read-multiple
-		"Enter severities: "
-		(mapcar
-		 'cadr (cdr (get 'debbugs-gnu-default-severities 'custom-type)))
-		nil t
+		"Enter severities: " debbugs-gnu-all-severities nil t
 		(mapconcat 'identity debbugs-gnu-default-severities ","))))
 
 	     ((equal key "package")
 	      (setq
 	       packages
 	       (completing-read-multiple
-		"Enter packages: "
-		(mapcar
-		 'cadr (cdr (get 'debbugs-gnu-default-packages 'custom-type)))
-		nil t (mapconcat 'identity debbugs-gnu-default-packages ","))))
+		"Enter packages: " debbugs-gnu-all-packages nil t
+		(mapconcat 'identity debbugs-gnu-default-packages ","))))
 
 	     ((equal key "archive")
 	      ;; We simplify, by assuming just archived bugs are requested.
@@ -373,26 +406,28 @@ marked as \"client-side filter\"."
 	  debbugs-gnu-current-filter nil)))
 
 ;;;###autoload
-(defun debbugs-gnu (severities &optional packages archivedp suppress)
+(defun debbugs-gnu (severities &optional packages archivedp suppress tags)
   "List all outstanding Emacs bugs."
   (interactive
-   (let (archivedp)
+   (let (severities archivedp)
      (list
-      (completing-read-multiple
-       "Severities: "
-       (mapcar 'cadr (cdr (get 'debbugs-gnu-default-severities 'custom-type)))
-       nil t (mapconcat 'identity debbugs-gnu-default-severities ","))
-      ;; The optional parameters are asked only when there is a prefix.
+      (setq severities
+	    (completing-read-multiple
+	     "Severities: " debbugs-gnu-all-severities nil t
+	     (mapconcat 'identity debbugs-gnu-default-severities ",")))
+      ;; The next parameters are asked only when there is a prefix.
       (if current-prefix-arg
 	  (completing-read-multiple
-	   "Packages: "
-	   (mapcar 'cadr (cdr (get 'debbugs-gnu-default-packages 'custom-type)))
-	   nil t (mapconcat 'identity debbugs-gnu-default-packages ","))
+	   "Packages: " debbugs-gnu-all-packages nil t
+	   (mapconcat 'identity debbugs-gnu-default-packages ","))
 	debbugs-gnu-default-packages)
       (when current-prefix-arg
 	(setq archivedp (y-or-n-p "Show archived bugs?")))
       (when (and current-prefix-arg (not archivedp))
-	(y-or-n-p "Suppress unwanted bugs?")))))
+	(y-or-n-p "Suppress unwanted bugs?"))
+      ;; This one must be asked for severity "tagged".
+      (when (member "tagged" severities)
+	(split-string (read-string "User tag(s): ") "," t)))))
 
   ;; Initialize variables.
   (when (and (file-exists-p debbugs-gnu-persistency-file)
@@ -411,6 +446,9 @@ marked as \"client-side filter\"."
       (add-to-list 'debbugs-gnu-current-query (cons 'package package))))
   (when archivedp
     (add-to-list 'debbugs-gnu-current-query '(archive . "1")))
+  (dolist (tag (if (consp tags) tags (list tags)))
+    (when (not (zerop (length tag)))
+      (add-to-list 'debbugs-gnu-current-query (cons 'tag tag))))
 
   (unwind-protect
       (let ((hits debbugs-gnu-default-hits-per-page)
@@ -469,13 +507,13 @@ marked as \"client-side filter\"."
 
 (defun debbugs-gnu-get-bugs (query)
   "Retrieve bugs numbers from debbugs.gnu.org according search criteria."
-  (let ((debbugs-port "gnu.org")
-	(tagged (when (member '(severity . "tagged") query)
-		  (copy-sequence debbugs-gnu-local-tags)))
-	(phrase (assoc 'phrase query))
-	args)
+  (let* ((debbugs-port "gnu.org")
+	 (tags (assoc 'tag query))
+	 (local-tags (and (member '(severity . "tagged") query) (not tags)))
+	 (phrase (assoc 'phrase query))
+	 args)
     ;; Compile query arguments.
-    (unless query
+    (unless (or query tags)
       (dolist (elt debbugs-gnu-default-packages)
 	(setq args (append args (list :package elt)))))
     (dolist (elt query)
@@ -496,34 +534,42 @@ marked as \"client-side filter\"."
 		 (list (intern (concat ":" (symbol-name (car elt))))
 		       (cdr elt)))))))
 
-    (cond
-     ;; If the query contains only the pseudo-severity "tagged", we
-     ;; return just the local tagged bugs.
-     ((and tagged (not (memq :severity args)))
-      (sort tagged '<))
-     ;; A full text query.
-     (phrase
-      (append
+    (sort
+     (cond
+      ;; If the query contains the pseudo-severity "tagged", we return
+      ;; just the local tagged bugs.
+      (local-tags (copy-sequence debbugs-gnu-local-tags))
+      ;; A full text query.
+      (phrase
        (mapcar
 	(lambda (x) (cdr (assoc "id" x)))
-	(apply 'debbugs-search-est args))
-       tagged))
-     ;; Otherwise, we retrieve the bugs from the server.
-     (t (sort (append (apply 'debbugs-get-bugs args) tagged) '<)))))
+	(apply 'debbugs-search-est args)))
+      ;; User tags.
+      (tags
+       (setq args (mapcar (lambda (x) (if (eq x :package) :user x)) args))
+       (apply 'debbugs-get-usertag args))
+      ;; Otherwise, we retrieve the bugs from the server.
+      (t (apply 'debbugs-get-bugs args)))
+     ;; Sort function.
+     '<)))
 
 (defvar debbugs-gnu-current-widget nil)
+(defvar debbugs-gnu-current-limit nil)
 
 (defvar widget-mouse-face)
 
 (defun debbugs-gnu-show-reports (widget)
   "Show bug reports as given in WIDGET property :bug-ids."
+  ;; The tabulated mode sets several local variables.  We must get rid
+  ;; of them.
+  (when (get-buffer (widget-get widget :buffer-name))
+    (kill-buffer (widget-get widget :buffer-name)))
   (pop-to-buffer (get-buffer-create (widget-get widget :buffer-name)))
   (debbugs-gnu-mode)
   (let ((inhibit-read-only t)
 	(debbugs-port "gnu.org"))
     (erase-buffer)
-    (set (make-local-variable 'debbugs-gnu-current-widget)
-	 widget)
+    (set (make-local-variable 'debbugs-gnu-current-widget) widget)
 
     (dolist (status (apply 'debbugs-get-status (widget-get widget :bug-ids)))
       (let* ((id (cdr (assq 'id status)))
@@ -652,6 +698,9 @@ Used instead of `tabulated-list-print-entry'."
 	(title            (aref cols 3))
 	(title-length     (nth 1 (aref tabulated-list-format 3))))
     (when (and
+	   ;; We may have a narrowing in effect.
+	   (or (not debbugs-gnu-current-limit)
+	       (memq (cdr (assq 'id list-id)) debbugs-gnu-current-limit))
 	   ;; Filter suppressed bugs.
 	   (or (not (widget-get debbugs-gnu-current-widget :suppress))
 	       (not (catch :suppress
@@ -713,6 +762,8 @@ Used instead of `tabulated-list-print-entry'."
     (define-key map "d" 'debbugs-gnu-display-status)
     (define-key map "g" 'debbugs-gnu-rescan)
     (define-key map "x" 'debbugs-gnu-toggle-suppress)
+    (define-key map "/" 'debbugs-gnu-narrow-to-status)
+    (define-key map "w" 'debbugs-gnu-widen)
     (define-key map "C" 'debbugs-gnu-send-control-message)
     map))
 
@@ -753,8 +804,8 @@ All normal editing commands are switched off.
 The following commands are available:
 
 \\{debbugs-gnu-mode-map}"
-  (set (make-local-variable 'debbugs-gnu-sort-state)
-       'number)
+  (set (make-local-variable 'debbugs-gnu-sort-state) 'number)
+  (set (make-local-variable 'debbugs-gnu-current-limit) nil)
   (setq tabulated-list-format [("Id"         5 debbugs-gnu-sort-id)
 			       ("State"     20 debbugs-gnu-sort-state)
 			       ("Submitter" 25 t)
@@ -837,6 +888,48 @@ The following commands are available:
   (tabulated-list-init-header)
   (tabulated-list-print))
 
+(defun debbugs-gnu-widen ()
+  "Display all the currently selected bug reports."
+  (interactive)
+  (let ((id (debbugs-gnu-current-id t))
+	(inhibit-read-only t))
+    (setq debbugs-gnu-current-limit nil)
+    (tabulated-list-init-header)
+    (tabulated-list-print)
+    (when id
+      (debbugs-gnu-goto id))))
+
+(defun debbugs-gnu-narrow-to-status (string &optional status-only)
+  "Only display the bugs matching STRING.
+If STATUS-ONLY (the prefix), ignore matches in the From and
+Subject fields."
+  (interactive "sNarrow to: \np")
+  (let ((id (debbugs-gnu-current-id t))
+	(inhibit-read-only t)
+	status)
+    (setq debbugs-gnu-current-limit nil)
+    (goto-char (point-min))
+    (while (not (eobp))
+      (setq status (debbugs-gnu-current-status))
+      (if (and (not (member string (assq 'keywords status)))
+	       (not (member string (assq 'severity status)))
+	       (or status-only
+		   (not (string-match string (cdr (assq 'originator status)))))
+	       (or status-only
+		   (not (string-match string (cdr (assq 'subject status))))))
+	  (delete-region (point) (progn (forward-line 1) (point)))
+	(push (cdr (assq 'id status)) debbugs-gnu-current-limit)
+	(forward-line 1)))
+    (when id
+      (debbugs-gnu-goto id))))
+
+(defun debbugs-gnu-goto (id)
+  "Go to the line displaying bug ID."
+  (goto-char (point-min))
+  (while (and (not (eobp))
+	      (not (equal (debbugs-gnu-current-id t) id)))
+    (forward-line 1)))
+
 (defun debbugs-gnu-toggle-tag ()
   "Toggle tag of the report in the current line."
   (interactive)
@@ -873,13 +966,21 @@ The following commands are available:
 (defun debbugs-gnu-current-status ()
   (get-text-property (line-beginning-position) 'tabulated-list-id))
 
-(defun debbugs-gnu-display-status (status)
-  "Display the status of the report on the current line."
-  (interactive (list (debbugs-gnu-current-status)))
+(defun debbugs-gnu-current-query ()
+  (widget-get debbugs-gnu-current-widget :query))
+
+(defun debbugs-gnu-display-status (query status)
+  "Display the query and status of the report on the current line."
+  (interactive (list (debbugs-gnu-current-query)
+		     (debbugs-gnu-current-status)))
   (pop-to-buffer "*Bug Status*")
-  (erase-buffer)
-  (pp status (current-buffer))
-  (goto-char (point-min)))
+  (let ((inhibit-read-only t))
+    (erase-buffer)
+    (when query (pp query (current-buffer)))
+    (when status (pp status (current-buffer)))
+    (goto-char (point-min)))
+  (set-buffer-modified-p nil)
+  (special-mode))
 
 (defun debbugs-gnu-select-report ()
   "Select the report on the current line."
@@ -964,7 +1065,8 @@ removed instead."
 	    "invalid"
 	    "reassign"
 	    "patch" "wontfix" "moreinfo" "unreproducible" "fixed" "notabug"
-	    "pending" "help" "security" "confirmed")
+	    "pending" "help" "security" "confirmed"
+	    "usertag")
 	  nil t)
 	 current-prefix-arg))
   (let* ((id (or debbugs-gnu-bug-number	; Set on group entry.
@@ -1002,7 +1104,7 @@ removed instead."
 	       ((equal message "owner")
 		(format "owner %d !\n" id))
 	       ((equal message "reassign")
-		(format "reassign %d %s\n" id (read-string "Package: ")))
+		(format "reassign %d %s\n" id (read-string "Package(s): ")))
 	       ((equal message "close")
 		(format "close %d %s\n" id version))
 	       ((equal message "done")
@@ -1016,12 +1118,111 @@ removed instead."
 	       ((equal message "invalid")
 		(format "tags %d notabug\ntags %d wontfix\nclose %d\n"
 			id id id))
+	       ((equal message "usertag")
+		(format "user %s\nusertag %d %s\n"
+			(completing-read
+			 "Package name or email address: "
+			 (append
+			  debbugs-gnu-all-packages (list user-mail-address))
+			 nil nil (car debbugs-gnu-default-packages))
+			id (read-string "User tag: ")))
 	       (t
 		(format "tags %d%s %s\n"
 			id (if reverse " -" "")
 			message))))
       (funcall send-mail-function))))
 
+(defvar debbugs-gnu-usertags-mode-map
+  (let ((map (make-sparse-keymap)))
+    (set-keymap-parent map tabulated-list-mode-map)
+    (define-key map "\r" 'debbugs-gnu-select-usertag)
+    (define-key map [mouse-1] 'debbugs-gnu-select-usertag)
+    (define-key map [mouse-2] 'debbugs-gnu-select-usertag)
+    map))
+
+(define-derived-mode debbugs-gnu-usertags-mode tabulated-list-mode "Usertags"
+  "Major mode for listing user tags.
+
+All normal editing commands are switched off.
+\\<debbugs-gnu-usertags-mode-map>
+
+The following commands are available:
+
+\\{debbugs-gnu-usertags-mode-map}"
+  (buffer-disable-undo)
+  (setq truncate-lines t)
+  (setq buffer-read-only t))
+
+;;;###autoload
+(defun debbugs-gnu-usertags (&optional users)
+  "List all outstanding Emacs bugs."
+  (interactive
+   (list
+    (if current-prefix-arg
+	(completing-read-multiple
+	 "Package name(s) or email address: "
+	 (append debbugs-gnu-all-packages (list user-mail-address)) nil nil
+	 (mapconcat 'identity debbugs-gnu-default-packages ","))
+      debbugs-gnu-default-packages)))
+
+  (unwind-protect
+      (let ((inhibit-read-only t)
+	    (debbugs-port "gnu.org")
+	    (buffer-name "*Emacs User Tags*")
+	    (user-tab-length
+	     (1+ (apply 'max (length "User") (mapcar 'length users)))))
+
+	;; Initialize variables.
+	(when (and (file-exists-p debbugs-gnu-persistency-file)
+		   (not debbugs-gnu-local-tags))
+	  (with-temp-buffer
+	    (insert-file-contents debbugs-gnu-persistency-file)
+	    (eval (read (current-buffer)))))
+
+	;; Create buffer.
+	(when (get-buffer buffer-name)
+	  (kill-buffer buffer-name))
+	(pop-to-buffer (get-buffer-create buffer-name))
+	(debbugs-gnu-usertags-mode)
+	(setq tabulated-list-format `[("User" ,user-tab-length t)
+				      ("Tag"  10 t)])
+	(setq tabulated-list-sort-key (cons "User" nil))
+	;(setq tabulated-list-printer 'debbugs-gnu-print-entry)
+	(erase-buffer)
+
+	;; Retrieve user tags.
+	(dolist (user users)
+	  (dolist (tag (sort (debbugs-get-usertag :user user) 'string<))
+	    (add-to-list
+	     'tabulated-list-entries
+	     ;; `tabulated-list-id' is the parameter list for `debbugs-gnu'.
+	     `((("tagged") (,user) nil nil (,tag))
+	       ,(vector (propertize user 'mouse-face widget-mouse-face)
+			(propertize tag 'mouse-face widget-mouse-face)))
+	     'append)))
+
+	;; Add local tags.
+	(when debbugs-gnu-local-tags
+	  (add-to-list
+	     'tabulated-list-entries
+	     `((("tagged"))
+	       ,(vector "" (propertize "(local tags)"
+				       'mouse-face widget-mouse-face)))))
+
+	;; Show them.
+	(tabulated-list-init-header)
+	(tabulated-list-print)
+
+	(set-buffer-modified-p nil)
+	(goto-char (point-min)))))
+
+(defun debbugs-gnu-select-usertag ()
+  "Select the user tag on the current line."
+  (interactive)
+  ;; We open the bug reports.
+  (let ((args (get-text-property (line-beginning-position) 'tabulated-list-id)))
+    (when args (apply 'debbugs-gnu args))))
+
 (provide 'debbugs-gnu)
 
 ;;; TODO: