[elpa] externals/debbugs 698e4c8 095/311: * debbugs.el (debbugs-get-usertag): Change parameters to a KEY-VALUE sequence.

[Stefan Monnier]

branch: externals/debbugs
commit 698e4c8ad66d5413a91634ad35355455e48514a2
Author: Michael Albinus <michael.albinus@gmx.de>
Commit: Michael Albinus <michael.albinus@gmx.de>

    * debbugs.el (debbugs-get-usertag): Change parameters to a KEY-VALUE 
sequence.
    
    * debbugs-gnu.el (debbugs-gnu): Rename USERTAGS to TAGS.
    (debbugs-gnu-get-bugs): Adapt to new interface of `debbugs-get-usertag'.
    (debbugs-gnu-display-status): Use `special-mode'.
    (debbugs-gnu-send-control-message): Implement "usertag" message.
    
    * README: "get_usertag" is implemented now.
---
 README         |  4 +--
 debbugs-gnu.el | 68 ++++++++++++++++++++++---------------------
 debbugs.el     | 92 ++++++++++++++++++++++++++++++++++++++++------------------
 3 files changed, 101 insertions(+), 63 deletions(-)

diff --git a/README b/README
index b7f5653..13ba777 100644
--- a/README
+++ b/README
@@ -6,8 +6,8 @@ command `M-x debbugs-gnu-search' for bug searching.
 This package works by implementing basic functions to access a debbugs
 SOAP server (see <http://wiki.debian.org/DebbugsSoapInterface>).  It
 implements the SOAP functions "get_bugs", "newest_bugs", "get_status",
-"get_bug_log" and "search_est".  The SOAP functions "get_usertag" and
-"get_versions" are not implemented (yet).
+"get_bug_log" and "search_est".  The SOAP function "get_versions" is
+not implemented (yet).
 
 You can connect to other debbugs servers by customizing the variable
 `debbugs-port'.
diff --git a/debbugs-gnu.el b/debbugs-gnu.el
index 9f52ced..753ac16 100644
--- a/debbugs-gnu.el
+++ b/debbugs-gnu.el
@@ -389,7 +389,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 +429,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 +490,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 +519,18 @@ 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 (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 +955,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 +1046,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,6 +1099,14 @@ 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 " -" "")
diff --git a/debbugs.el b/debbugs.el
index adb0ce4..b3f7fe7 100644
--- a/debbugs.el
+++ b/debbugs.el
@@ -320,45 +320,81 @@ Example:
           (cdr (assoc 'value x))))
        object))))
 
-(defun debbugs-get-usertag (user &rest tags)
-  "Return a list of bug numbers which are tagged by USER.
+(defun debbugs-get-usertag (&rest query)
+  "Return a list of bug numbers which match QUERY.
 
-USER, a string, is either the email address of the user who has
-applied a user tag, or a pseudo-user like \"emacs\".  Usually,
-pseudo-users are package names.
+QUERY is a sequence of keyword-value pairs where the values are
+strings, i.e. :KEYWORD \"VALUE\" [:KEYWORD \"VALUE\"]*
 
-TAGS is a list of strings applied as user tags.  The returning
-bug numbers list is filtered for these tags.
+Valid keywords are:
 
-If TAGS is nil, no bug numbers will be returned but a list of
-existing tags for USER.
+  :package -- The value is the name of the package a bug belongs
+  to, like \"emacs\", \"coreutils\", \"gnus\", or \"tramp\".  It
+  can also be an email address of a user who has applied a user
+  tag.  The special email address \"me\" is used as pattern,
+  replaced with `user-mail-address'.  There must be at least one
+  such entry; it is recommended to have exactly one.
+
+  :tag -- A string applied as user tag.  Often, it is a
+  subproduct identification, like \"cedet\" or \"tramp\" for the
+  package \"emacs\".
+
+If there is no :tag entry, no bug numbers will be returned but a list of
+existing user tags for :package.
 
 Example:
 
-  \(debbugs-get-usertag \"emacs\")
+  \(debbugs-get-usertag :package \"emacs\")
 
   => (\"www\" \"solaris\" \"ls-lisp\" \"cygwin\")
 
-  \(debbugs-get-usertag \"emacs\" \"www\" \"cygwin\")
+  \(debbugs-get-usertag :package \"emacs\" :tag \"www\" :tag \"cygwin\")
 
   => (807 1223 5637)"
-  (when (stringp user)
-    (let ((object
-          (car (soap-invoke debbugs-wsdl debbugs-port "get_usertag" user)))
-         result)
-      (if (null tags)
-         ;; Return the list of existing tags.
-         (mapcar
-          (lambda (x) (symbol-name (car x)))
-          object)
-
-       ;; Return bug numbers.
-       (mapcar
-        (lambda (x)
-          (when (member (symbol-name (car x)) tags)
-            (setq result (append (cdr x) result))))
-        object)
-       (sort result '<)))))
+
+  (let (user tags kw key val object result)
+    ;; Check query.
+    (while (and (consp query) (<= 2 (length query)))
+      (setq kw (pop query)
+           val (pop query))
+      (unless (and (keywordp kw) (stringp val))
+       (error "Wrong query: %s %s" kw val))
+      (setq key (substring (symbol-name kw) 1))
+      (case kw
+       ((:package)
+        ;; Value shall be one word.
+        (if (string-match "\\`\\S-+\\'" val)
+            (progn
+              (when (string-equal "me" val)
+                (setq val user-mail-address))
+              (when (string-match "<\\(.+\\)>" val)
+                (setq val (match-string 1 val)))
+              (add-to-list 'user val))
+          (error "Wrong %s: %s" key val)))
+       ((:tag)
+        ;; Value shall be one word.  Extract email address, if existing.
+        (if (string-match "\\`\\S-+\\'" val)
+            (add-to-list 'tags val)
+          (error "Wrong %s: %s" key val)))
+       (t (error "Unknown key: %s" kw))))
+
+    (unless (null query)
+      (error "Unknown key: %s" (car query)))
+    (unless (= (length user) 1)
+      (error "There must be exactly one :package entry"))
+
+    (setq
+     object
+     (car (soap-invoke debbugs-wsdl debbugs-port "get_usertag" (car user))))
+
+    (if (null tags)
+       ;; Return the list of existing tags.
+       (mapcar (lambda (x) (symbol-name (car x))) object)
+
+      ;; Return bug numbers.
+      (dolist (elt object result)
+       (when (member (symbol-name (car elt)) tags)
+         (setq result (append (cdr elt) result)))))))
 
 (defun debbugs-get-bug-log (bug-number)
   "Return a list of messages related to BUG-NUMBER.