X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/721c270052e4e4fc671472ac871d6fe61be3681b..09936b35a29904362939ad734d97f49ffbd1d726:/packages/debbugs/debbugs.el

diff --git a/packages/debbugs/debbugs.el b/packages/debbugs/debbugs.el
index 4bfbb903c..49960fe14 100644
--- a/packages/debbugs/debbugs.el
+++ b/packages/debbugs/debbugs.el
@@ -1,11 +1,12 @@
 ;;; debbugs.el --- SOAP library to access debbugs servers
 
-;; Copyright (C) 2011-2015 Free Software Foundation, Inc.
+;; Copyright (C) 2011-2016 Free Software Foundation, Inc.
 
 ;; Author: Michael Albinus <michael.albinus@gmx.de>
 ;; Keywords: comm, hypermedia
 ;; Package: debbugs
 ;; Version: 0.8
+;; Package-Requires: ((async "1.6"))
 
 ;; This file is not part of GNU Emacs.
 
@@ -36,6 +37,10 @@
 (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")
+
 (defgroup debbugs nil
   "Debbugs library"
   :group 'hypermedia)
@@ -95,6 +100,47 @@ This corresponds to the Debbugs server to be accessed, either
       default-directory)))
   "The WSDL object to be used describing the SOAP interface.")
 
+;; Please do not increase this value, otherwise we would run into
+;; performance problems on the server.  Maybe we need to change this a
+;; server specific value.
+(defconst debbugs-max-hits-per-request 500
+  "The max number of bugs or results per soap invocation.")
+
+(defvar debbugs-cache-data
+  (make-hash-table :test 'equal :size debbugs-max-hits-per-request)
+  "Hash table of retrieved bugs.")
+
+(defconst debbugs-cache-expiry (* 60 60)
+  "How many seconds debbugs results are cached, or nil to disable expiring.")
+
+(defvar debbugs-soap-invoke-async-object nil
+  "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)))))
+
 (defun debbugs-get-bugs (&rest query)
   "Return a list of bug numbers which match QUERY.
 
@@ -223,7 +269,8 @@ Every returned entry is an association list with the following attributes:
   `package': A list of package names the bug belongs to.
 
   `severity': The severity of the bug report. This can be
-  \"important\", \"grave\", \"normal\", \"minor\" or \"wishlist\".
+  \"critical\", \"grave\", \"serious\", \"important\",
+  \"normal\", \"minor\" or \"wishlist\".
 
   `tags': The status of the bug report, a list of strings.  This
   can be \"fixed\", \"notabug\", \"wontfix\", \"unreproducible\",
@@ -290,41 +337,104 @@ Example:
        \(last_modified . 1271200046.0)
        \(pending . \"pending\")
        \(package \"emacs\")))"
-  (when bug-numbers
-    (let ((object
-	   (car
-	    (soap-invoke
-	     debbugs-wsdl debbugs-port "get_status"
-	     (apply 'vector bug-numbers)))))
-      (mapcar
-       (lambda (x)
-	 (let (y)
-	   ;; "archived" is the number 1 or 0.
-	   (setq y (assoc 'archived (cdr (assoc 'value x))))
-	   (setcdr y (= (cdr y) 1))
-	   ;; "found_versions" and "fixed_versions" are lists,
-	   ;; containing strings or numbers.
-	   (dolist (attribute '(found_versions fixed_versions))
-	     (setq y (assoc attribute (cdr (assoc 'value x))))
-	     (setcdr y (mapcar
-			(lambda (z) (if (numberp z) (number-to-string z) z))
-			(cdr y))))
-	   ;; "mergedwith", "blocks" and "blockedby are strings,
-	   ;; containing blank separated bug numbers.
-	   (dolist (attribute '(mergedwith blocks blockedby))
-	     (setq y (assoc attribute (cdr (assoc 'value x))))
-	     (when (stringp (cdr y))
-	       (setcdr y (mapcar
-			  'string-to-number (split-string (cdr y) " " t)))))
-	   ;; "package" is a string, containing comma separated
-	   ;; package names.  "keywords" and "tags" are strings,
-	   ;; containing blank separated package names.
-	   (dolist (attribute '(package keywords tags))
-	     (setq y (assoc attribute (cdr (assoc 'value x))))
-	     (when (stringp (cdr y))
-	       (setcdr y (split-string (cdr y) ",\\| " t))))
-	   (cdr (assoc 'value x))))
-       object))))
+  (let (cached-bugs)
+    ;; Check for cached bugs.
+    (setq bug-numbers
+	  (delete
+	   nil
+	   (mapcar
+	    (lambda (bug)
+	      (let ((status (gethash bug debbugs-cache-data)))
+		(if (and
+		     status
+		     (or
+		      (null debbugs-cache-expiry)
+		      (> (cdr (assoc 'cache_time status))
+			 (- (float-time) debbugs-cache-expiry))))
+		    (progn
+		      (setq cached-bugs (append cached-bugs (list status)))
+		      nil)
+		  bug)))
+	    bug-numbers)))
+
+    ;; Retrieve the data.
+    (setq debbugs-soap-invoke-async-object nil)
+    (when bug-numbers
+      (if (<= (length bug-numbers) debbugs-max-hits-per-request)
+	  ;; Do it directly.
+	  (setq debbugs-soap-invoke-async-object
+		(car (soap-invoke
+		      debbugs-wsdl debbugs-port "get_status"
+		      (apply 'vector bug-numbers))))
+
+	;; Retrieve bugs asynchronously.
+	(let ((bug-ids bug-numbers)
+	      results)
+	  (setq debbugs-soap-invoke-async-object nil)
+	  (while bug-ids
+	    (setq results
+		  (append
+		   results
+		   (list
+		    (debbugs-soap-invoke-async
+		     "get_status"
+		     (apply
+		      'vector
+		      (butlast
+		       bug-ids (- (length bug-ids)
+				  debbugs-max-hits-per-request))))))
+
+		  bug-ids
+		  (last bug-ids (- (length bug-ids)
+				   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))))))))
+
+    (append
+     cached-bugs
+     ;; Massage results.
+     (mapcar
+      (lambda (x)
+	(let (y)
+	  ;; "archived" is the number 1 or 0.
+	  (setq y (assoc 'archived (cdr (assoc 'value x))))
+	  (setcdr y (= (cdr y) 1))
+	  ;; "found_versions" and "fixed_versions" are lists,
+	  ;; containing strings or numbers.
+	  (dolist (attribute '(found_versions fixed_versions))
+	    (setq y (assoc attribute (cdr (assoc 'value x))))
+	    (setcdr y (mapcar
+		       (lambda (z) (if (numberp z) (number-to-string z) z))
+		       (cdr y))))
+	  ;; "mergedwith", "blocks" and "blockedby are strings,
+	  ;; containing blank separated bug numbers.
+	  (dolist (attribute '(mergedwith blocks blockedby))
+	    (setq y (assoc attribute (cdr (assoc 'value x))))
+	    (when (stringp (cdr y))
+	      (setcdr y (mapcar
+			 'string-to-number (split-string (cdr y) " " t)))))
+	  ;; "package" is a string, containing comma separated
+	  ;; package names.  "keywords" and "tags" are strings,
+	  ;; containing blank separated package names.
+	  (dolist (attribute '(package keywords tags))
+	    (setq y (assoc attribute (cdr (assoc 'value x))))
+	    (when (stringp (cdr y))
+	      (setcdr y (split-string (cdr y) ",\\| " t))))
+	  ;; Cache the result, and return.
+	  (puthash
+	   (cdr (assoc 'key x))
+	   ;; Put also a time stamp.
+	   (cons (cons 'cache_time (float-time)) (cdr (assoc 'value x)))
+	   debbugs-cache-data)))
+      debbugs-soap-invoke-async-object))))
 
 (defun debbugs-get-usertag (&rest query)
   "Return a list of bug numbers which match QUERY.