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

diff --git a/packages/debbugs/debbugs-gnu.el b/packages/debbugs/debbugs-gnu.el
index 35e412460..a46d99ef4 100644
--- a/packages/debbugs/debbugs-gnu.el
+++ b/packages/debbugs/debbugs-gnu.el
@@ -34,6 +34,7 @@
 ;;
 ;;   (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
 ;;
@@ -108,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)
@@ -140,8 +157,8 @@
   :version "24.1")
 
 (defconst debbugs-gnu-all-severities
-  "*List of all possible severities."
-  (mapcar 'cadr (cdr (get 'debbugs-gnu-default-severities 'custom-type))))
+  (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."
@@ -160,8 +177,8 @@
   :version "24.1")
 
 (defconst debbugs-gnu-all-packages
-  "*List of all possible package names."
-  (mapcar 'cadr (cdr (get 'debbugs-gnu-default-packages 'custom-type))))
+  (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."
@@ -389,7 +406,7 @@ marked as \"client-side filter\"."
 	  debbugs-gnu-current-filter nil)))
 
 ;;;###autoload
-(defun debbugs-gnu (severities &optional packages archivedp suppress usertags)
+(defun debbugs-gnu (severities &optional packages archivedp suppress tags)
   "List all outstanding Emacs bugs."
   (interactive
    (let (severities archivedp)
@@ -429,9 +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 (usertag (if (consp usertags) usertags (list usertags)))
-    (when (not (zerop (length usertag)))
-      (add-to-list 'debbugs-gnu-current-query (cons 'usertag usertag))))
+  (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)
@@ -490,16 +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))
-	usertags args)
-    ;; Compile query and usertags arguments.
-    (dolist (elt query)
-      (when (equal (car elt) 'usertag)
-	(add-to-list 'usertags (cdr elt))))
-    (unless (or query usertags)
+  (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 (or query tags)
       (dolist (elt debbugs-gnu-default-packages)
 	(setq args (append args (list :package elt)))))
     (dolist (elt query)
@@ -522,24 +536,20 @@ marked as \"client-side filter\"."
 
     (sort
      (cond
-      ;; If the query contains only the pseudo-severity "tagged", we
-      ;; return just the local tagged bugs.
-      ((and tagged (not usertags) (not (memq :severity args))) tagged)
+      ;; 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
-       (append
-	(mapcar
-	 (lambda (x) (cdr (assoc "id" x)))
-	 (apply 'debbugs-search-est args))
-	tagged))
+       (mapcar
+	(lambda (x) (cdr (assoc "id" x)))
+	(apply 'debbugs-search-est args)))
       ;; User tags.
-      (usertags
-       (let (result)
-	 (dolist (elt packages result)
-	   (setq result
-		 (append result (apply 'debbugs-get-usertag elt usertags))))))
+      (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 (append (apply 'debbugs-get-bugs args) tagged)))
+      (t (apply 'debbugs-get-bugs args)))
      ;; Sort function.
      '<)))
 
@@ -964,10 +974,12 @@ Subject fields."
   (interactive (list (debbugs-gnu-current-query)
 		     (debbugs-gnu-current-status)))
   (pop-to-buffer "*Bug Status*")
-  (erase-buffer)
-  (when query (pp query (current-buffer)))
-  (when status (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 ()
@@ -1053,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.
@@ -1105,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: