X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/42a7b2ee05354745f234df7325939efd4f8abca2..aea4c6ae3a0b470ca16b2b209f8ee344c7b21a94:/packages/debbugs/debbugs.el

diff --git a/packages/debbugs/debbugs.el b/packages/debbugs/debbugs.el
index f14528008..ad5147444 100644
--- a/packages/debbugs/debbugs.el
+++ b/packages/debbugs/debbugs.el
@@ -1,12 +1,12 @@
-;;; debbugs.el --- SOAP library to access debbugs servers
+;;; debbugs.el --- SOAP library to access debbugs servers  -*- lexical-binding:t -*-
 
 ;; Copyright (C) 2011-2016 Free Software Foundation, Inc.
 
 ;; Author: Michael Albinus <michael.albinus@gmx.de>
 ;; Keywords: comm, hypermedia
 ;; Package: debbugs
-;; Version: 0.9
-;; Package-Requires: ((async "1.6"))
+;; Version: 0.9.6
+;; Package-Requires: ((soap-client "3.1.1") (cl-lib "0.5"))
 
 ;; This file is not part of GNU Emacs.
 
@@ -35,11 +35,7 @@
 
 ;(setq soap-debug t message-log-max t)
 (require 'soap-client)
-(eval-when-compile (require 'cl))
-
-(declare-function soap-invoke-async "soap-client")
-(declare-function async-start "async")
-(declare-function async-get "async")
+(eval-when-compile (require 'cl-lib))
 
 (defgroup debbugs nil
   "Debbugs library"
@@ -122,29 +118,13 @@ This corresponds to the Debbugs server to be accessed, either
   "The object manipulated by `debbugs-soap-invoke-async'.")
 
 (defun debbugs-soap-invoke-async (operation-name &rest parameters)
-  "Invoke the SOAP connection asynchronously.
-If possible, it uses `soap-invoke-async' from soapclient 3.0.
-Otherwise, `async-start' from the async package is used."
-  (if (fboundp 'soap-invoke-async)
-      ;; This is soap-client 3.0.
-      (apply
-       'soap-invoke-async
-       (lambda (response &rest args)
-	 (setq debbugs-soap-invoke-async-object
-	       (append debbugs-soap-invoke-async-object (car response))))
-       nil
-       debbugs-wsdl debbugs-port operation-name parameters)
-    ;; Fallback with async.
-    (async-start
-     `(lambda ()
-	(load ,(locate-library "soap-client"))
-	(apply
-	 'soap-invoke
-	 (soap-load-wsdl
-	  ,(expand-file-name
-	    "Debbugs.wsdl"
-	    (file-name-directory (locate-library "debbugs"))))
-	 ,debbugs-port ,operation-name ',parameters)))))
+  "Invoke the SOAP connection asynchronously."
+  (apply
+   #'soap-invoke-async
+   (lambda (response &rest _args)
+     (setq debbugs-soap-invoke-async-object
+	   (append debbugs-soap-invoke-async-object (car response))))
+   nil debbugs-wsdl debbugs-port operation-name parameters))
 
 (defun debbugs-get-bugs (&rest query)
   "Return a list of bug numbers which match QUERY.
@@ -201,8 +181,8 @@ Valid keywords are:
   the value of field `affects' in bug's status.  The returned bugs
   do not necessary belong to this package.
 
-  :status -- Status of bug.  Valid values are \"done\",
-  \"forwarded\" and \"open\".
+  :status -- Status of bug.  Valid values are \"pending\",
+  \"forwarded\", \"fixed\" and \"done\".
 
   :archive -- A keyword to filter for bugs which are already
   archived, or not.  Valid values are \"0\" (not archived),
@@ -228,7 +208,7 @@ patch:
       (unless (and (keywordp kw) (stringp val))
 	(error "Wrong query: %s %s" kw val))
       (setq key (substring (symbol-name kw) 1))
-      (case kw
+      (cl-case kw
 	((:package :severity :tag :src :affects)
 	 ;; Value shall be one word.
 	 (if (string-match "\\`\\S-+\\'" val)
@@ -245,8 +225,8 @@ patch:
 	       (setq vec (vconcat vec (list key val))))
 	   (error "Wrong %s: %s" key val)))
 	(:status
-	 ;; Possible values: "done", "forwarded" and "open"
-	 (if (string-match "\\`\\(done\\|forwarded\\|open\\)\\'" val)
+	 ;; Possible values: "pending", "forwarded", "fixed" and "done".
+	 (if (string-match "\\`\\(pending\\|forwarded\\|fixed\\|done\\)\\'" val)
 	     (setq vec (vconcat vec (list key val)))
 	   (error "Wrong %s: %s" key val)))
 	(:archive
@@ -264,6 +244,27 @@ patch:
   "Return the list of bug numbers, according to AMOUNT (a number) latest bugs."
   (sort (car (soap-invoke debbugs-wsdl debbugs-port "newest_bugs" amount)) '<))
 
+(defun debbugs-convert-soap-value-to-string (string-value)
+  "If STRING-VALUE is unibyte, decode its contents as a UTF-8 string.
+If STRING-VALUE is a multibyte string, then `soap-client'
+received an xsd:string for this value, and will have decoded it
+already.
+
+If STRING-VALUE is a unibyte string, then `soap-client' received
+an xsd:base64Binary, and ran `base64-decode-string' on it to
+produce a unibyte string of bytes.
+
+For some reason, the Debbugs server code base64-encodes strings
+that contain UTF-8 characters, and returns them as
+xsd:base64Binary, instead of just returning them as xsd:string.
+Therefore, when STRING-VALUE is a unibyte string, we assume its
+bytes represent a UTF-8 string and decode them accordingly."
+  (if (stringp string-value)
+      (if (not (multibyte-string-p string-value))
+	  (decode-coding-string string-value 'utf-8)
+	string-value)
+    (error "Invalid string value")))
+
 (defun debbugs-get-status (&rest bug-numbers)
   "Return a list of status entries for the bugs identified by BUG-NUMBERS.
 
@@ -281,7 +282,7 @@ Every returned entry is an association list with the following attributes:
   can be \"fixed\", \"notabug\", \"wontfix\", \"unreproducible\",
   \"moreinfo\" or \"patch\".
 
-  `pending': The string \"pending\", \"forwarded\" or \"done\".
+  `pending': The string \"pending\", \"forwarded\", \"fixed\" or \"done\".
 
   `subject': Subject/Title of the bugreport.
 
@@ -379,7 +380,7 @@ Example:
 		  (debbugs-soap-invoke-async
 		   "get_status"
 		   (apply
-		    'vector
+		    #'vector
 		    (butlast
 		     bug-ids (- (length bug-ids)
 				debbugs-max-hits-per-request))))))
@@ -389,14 +390,8 @@ Example:
 				 debbugs-max-hits-per-request))))
 
 	(dolist (res results)
-	  (if (bufferp res)
-	      ;; This is soap-client 3.0.
-	      (while (buffer-live-p res)
-		(accept-process-output (get-buffer-process res) 0.1))
-	    ;; Fallback with async.
-	    (dolist (status (async-get res))
-	      (setq debbugs-soap-invoke-async-object
-		    (append debbugs-soap-invoke-async-object status)))))))
+	  (while (buffer-live-p res)
+	    (accept-process-output (get-buffer-process res) 0.1)))))
 
     (append
      cached-bugs
@@ -420,7 +415,13 @@ Example:
 	    (setq y (assoc attribute (cdr (assoc 'value x))))
 	    (when (stringp (cdr y))
 	      (setcdr y (mapcar
-			 'string-to-number (split-string (cdr y) " " t)))))
+			 #'string-to-number (split-string (cdr y) " " t)))))
+	  ;; "subject", "originator", "owner" and "summary" may be an
+	  ;; xsd:base64Binary value containing a UTF-8-encoded string.
+	  (dolist (attribute '(subject originator owner summary))
+	    (setq y (assoc attribute (cdr (assoc 'value x))))
+	    (when (stringp (cdr y))
+	      (setcdr y (debbugs-convert-soap-value-to-string (cdr y)))))
 	  ;; "package" is a string, containing comma separated
 	  ;; package names.  "keywords" and "tags" are strings,
 	  ;; containing blank separated package names.
@@ -433,7 +434,7 @@ Example:
 	      (puthash
 	       (cdr (assoc 'key x))
 	       ;; Put also a time stamp.
-	       (cons (cons 'cache_time (floor (float-time)))
+	       (cons (cons 'cache_time (float-time))
 		     (cdr (assoc 'value x)))
 	       debbugs-cache-data)
 	    ;; Don't cache.
@@ -480,7 +481,7 @@ Example:
       (unless (and (keywordp kw) (stringp val))
 	(error "Wrong query: %s %s" kw val))
       (setq key (substring (symbol-name kw) 1))
-      (case kw
+      (cl-case kw
 	((:user)
 	 ;; Value shall be one word.  Extract email address, if existing.
 	 (if (string-match "\\`\\S-+\\'" val)
@@ -489,12 +490,12 @@ Example:
 		 (setq val user-mail-address))
 	       (when (string-match "<\\(.+\\)>" val)
 		 (setq val (match-string 1 val)))
-	       (pushnew val user :test #'equal))
+	       (cl-pushnew val user :test #'equal))
 	   (error "Wrong %s: %s" key val)))
 	((:tag)
 	 ;; Value shall be one word.
 	 (if (string-match "\\`\\S-+\\'" val)
-	     (pushnew val tags :test #'equal)
+	     (cl-pushnew val tags :test #'equal)
 	   (error "Wrong %s: %s" key val)))
 	(t (error "Unknown key: %s" kw))))
 
@@ -564,17 +565,15 @@ The following conditions are possible:
 
   ATTRIBUTE is one of the following keywords:
 
-  :status --  Status of bug.  Valid values are \"done\",
-  \"forwarded\" and \"open\".
-
   :subject, :@title -- The subject of a message or the title of
   the bug, a string.
 
   :date, :@cdate -- The submission or modification dates of a
   message, a number.
 
-  :submitter, :@author -- The email address of the submitter of a
-  bug or the author of a message belonging to this bug, a string.
+  :@author -- The email address of the author of a message
+  belonging to this bug, a string.  It may be different than
+  the email of the person submitting the bug.
   The special email address \"me\" is used as pattern, replaced
   with `user-mail-address'.
 
@@ -660,7 +659,7 @@ Examples:
 
   (let ((phrase (assoc :phrase query))
 	args result)
-    (if (and phrase (not (member :skip phrase)) (not (member :skip phrase)))
+    (if (and phrase (not (member :skip phrase)) (not (member :max phrase)))
 	;; We loop, until we have all results.
 	(let ((skip 0)
 	      (query (delete phrase query))
@@ -668,7 +667,7 @@ Examples:
 	  (while skip
 	    (setq result1
 		  (apply
-		   'debbugs-search-est
+		   #'debbugs-search-est
 		   (append
 		    (list
 		     (append
@@ -682,6 +681,9 @@ Examples:
 
       ;; Compile search arguments.
       (dolist (elt query)
+        ;; FIXME: `vec' is used in an O(N²) way.  It should be a list instead,
+        ;; on which we push elements, and we only convert it to a vector at
+        ;; the end.
 	(let (vec kw key val
 		  phrase-cond attr-cond)
 
@@ -720,8 +722,9 @@ Examples:
 
 	      ;; Attribute condition.
 	      ((:submitter :@author)
-	       ;; It shouldn't happen in a phrase condition.
-	       (if phrase-cond
+	       ;; It shouldn't happen.
+	       (if (or (and (eq kw :submitter) phrase-cond)
+		       (and (eq kw :@author) attr-cond))
 		   (error "Wrong keyword: %s" kw))
 	       (if (not (stringp (car elt)))
 		   (setq vec (vconcat vec (list key "")))
@@ -736,7 +739,8 @@ Examples:
 		     (unless (member x val)
 		       (setq val (append val (list x))))))
 		 (setq vec
-		       (vconcat vec (list key (mapconcat 'identity val " "))))))
+		       (vconcat
+			vec (list key (mapconcat #'identity val " "))))))
 
 	      (:status
 	       ;; It shouldn't happen in a phrase condition.
@@ -745,15 +749,17 @@ Examples:
 	       (setq attr-cond t)
 	       (if (not (stringp (car elt)))
 		   (setq vec (vconcat vec (list key "")))
-		 ;; Possible values: "done", "forwarded" and "open"
+		 ;; Possible values: "pending", "forwarded", "fixed" and "done".
 		 (while  (and (stringp (car elt))
 			      (string-match
-			       "\\`\\(done\\|forwarded\\|open\\)\\'" (car elt)))
+			       "\\`\\(pending\\|forwarded\\|fixed\\|done\\)\\'"
+			       (car elt)))
 		   (let ((x (pop elt)))
 		     (unless (member x val)
 		       (setq val (append val (list x))))))
 		 (setq vec
-		       (vconcat vec (list key (mapconcat 'identity val " "))))))
+		       (vconcat
+			vec (list key (mapconcat #'identity val " "))))))
 
 	      ((:subject :package :tags :severity :@title)
 	       ;; It shouldn't happen in a phrase condition.
@@ -768,7 +774,8 @@ Examples:
 		     (unless (member x val)
 		       (setq val (append val (list x))))))
 		 (setq vec
-		       (vconcat vec (list key (mapconcat 'identity val " "))))))
+		       (vconcat
+			vec (list key (mapconcat #'identity val " "))))))
 
 	      ((:date :@cdate)
 	       ;; It shouldn't happen in a phrase condition.
@@ -784,7 +791,8 @@ Examples:
 		       (setq val (append val (list x))))))
 		 (setq vec
 		       (vconcat
-			vec (list key (mapconcat 'number-to-string val " "))))))
+			vec
+			(list key (mapconcat #'number-to-string val " "))))))
 
 	      ((:operator :order)
 	       ;; It shouldn't happen in a phrase condition.
@@ -817,7 +825,7 @@ BUG-OR-MESSAGE must be list element returned by either
 Example: Return the originator of last submitted bug.
 
 \(debbugs-get-attribute
-  \(car \(apply 'debbugs-get-status \(debbugs-newest-bugs 1))) 'originator)"
+  \(car \(apply #'debbugs-get-status \(debbugs-newest-bugs 1))) 'originator)"
   (cdr (assoc attribute bug-or-message)))
 
 (defun debbugs-get-message-numbers (messages)
@@ -838,7 +846,7 @@ If there is no message with MESSAGE-NUMBER, the function returns `nil'.
 
 Example: Return the first message of last submitted bug.
 
-\(let \(\(messages \(apply 'debbugs-get-bug-log \(debbugs-newest-bugs 1))))
+\(let \(\(messages \(apply #'debbugs-get-bug-log \(debbugs-newest-bugs 1))))
   \(debbugs-get-message messages
 		       \(car \(debbugs-get-message-numbers messages))))"
   (while (and messages