From 8ba097f55d0f497676a043d7eba1c24d2552493f Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Sat, 2 Jan 2016 17:36:54 +0100 Subject: [PATCH] Move asynchronous calls in debbugs to SOAP function level. * packages/debbugs/debbugs-gnu.el (top): Don't require `async'. (debbugs-gnu-default-hits-per-page): Remove. (debbugs-gnu-show-reports): Do not call `debbugs-get-status' asynchronously anymore. * packages/debbugs/debbugs.el (soap-invoke-async, async-start) (async-get): Declare. (debbugs-max-hits-per-request): New defconst. (debbugs-soap-invoke-async-object): New defvar. (debbugs-soap-invoke-async): New defun. (debbugs-get-status): Use them. --- packages/debbugs/debbugs-gnu.el | 212 +++++++++++++++----------------- packages/debbugs/debbugs.el | 140 ++++++++++++++++----- 2 files changed, 204 insertions(+), 148 deletions(-) diff --git a/packages/debbugs/debbugs-gnu.el b/packages/debbugs/debbugs-gnu.el index e2607a2b9..d0ccf2979 100644 --- a/packages/debbugs/debbugs-gnu.el +++ b/packages/debbugs/debbugs-gnu.el @@ -6,7 +6,6 @@ ;; Michael Albinus ;; Keywords: comm, hypermedia, maint ;; Package: debbugs -;; Package-Requires: ((async)) ;; Version: 0.8 ;; This file is not part of GNU Emacs. @@ -144,7 +143,6 @@ (require 'tabulated-list) (require 'add-log) (require 'subr-x) -(require 'async) (eval-when-compile (require 'cl)) (autoload 'article-decode-charset "gnus-art") @@ -188,6 +186,8 @@ "*The list severities bugs are searched for. \"tagged\" is not a severity but marks locally tagged bugs." ;; + ;; /ssh:debbugs:/etc/debbugs/config @gSeverityList + ;; We don't use "critical" and "grave". :group 'debbugs-gnu :type '(set (const "serious") (const "important") @@ -236,11 +236,6 @@ (mapcar 'cadr (cdr (get 'debbugs-gnu-default-packages 'custom-type))) "*List of all possible package names.") -;; Please do not increase this value, otherwise we would run into -;; performance problems on the server. -(defconst debbugs-gnu-default-hits-per-page 500 - "The number of bugs shown per page.") - (defcustom debbugs-gnu-default-suppress-bugs '((pending . "done")) "*A list of specs for bugs to be suppressed. @@ -576,8 +571,7 @@ marked as \"client-side filter\"." "Show bug reports." (let ((inhibit-read-only t) (debbugs-port "gnu.org") - (buffer-name "*Emacs Bugs*") - all-proc) + (buffer-name "*Emacs Bugs*")) ;; The tabulated mode sets several local variables. We must get ;; rid of them. (when (get-buffer buffer-name) @@ -585,113 +579,98 @@ marked as \"client-side filter\"." (switch-to-buffer (get-buffer-create buffer-name)) (debbugs-gnu-mode) - ;; Retrieve all bugs in chunks of `debbugs-gnu-default-hits-per-page'. - (let ((bug-ids (debbugs-gnu-get-bugs debbugs-gnu-current-query)) - (hits debbugs-gnu-default-hits-per-page) - curr-ids) - (while bug-ids - (setq curr-ids (butlast bug-ids (- (length bug-ids) hits)) - bug-ids (last bug-ids (- (length bug-ids) hits)) - all-proc - (append all-proc - (list - (async-start - `(lambda () - (load ,(locate-library "debbugs")) - (apply 'debbugs-get-status ',curr-ids)))))))) - ;; Print bug reports. - (dolist (proc all-proc) - (dolist (status (async-get proc)) - (let* ((id (cdr (assq 'id status))) - (words - (mapconcat - 'identity - (cons (cdr (assq 'severity status)) - (cdr (assq 'keywords status))) - ",")) - (address (mail-header-parse-address - (decode-coding-string (cdr (assq 'originator status)) - 'utf-8))) - (owner (if (cdr (assq 'owner status)) - (car (mail-header-parse-address - (decode-coding-string (cdr (assq 'owner status)) - 'utf-8))))) - (subject (decode-coding-string (cdr (assq 'subject status)) - 'utf-8)) - merged) - (unless (equal (cdr (assq 'pending status)) "pending") - (setq words (concat words "," (cdr (assq 'pending status))))) - (let ((packages (delete "emacs" (cdr (assq 'package status))))) - (when packages - (setq words - (concat words "," (mapconcat 'identity packages ","))))) - (when (setq merged (cdr (assq 'mergedwith status))) - (setq words (format "%s,%s" - (if (numberp merged) - merged - (mapconcat 'number-to-string merged ",")) - words))) - (when (or (not merged) - (not (let ((found nil)) - (dolist (id (if (listp merged) - merged - (list merged))) - (dolist (entry tabulated-list-entries) - (when (equal id (cdr (assq 'id (car entry)))) - (setq found t)))) - found))) - (add-to-list - 'tabulated-list-entries - (list - status - (vector - (propertize - (format "%5d" id) - 'face - ;; Mark tagged bugs. - (if (memq id debbugs-gnu-local-tags) - 'debbugs-gnu-tagged - 'default)) - (propertize - ;; Mark status and age. - words - 'face - (cond - ((cdr (assq 'archived status)) - 'debbugs-gnu-archived) - ((equal (cdr (assq 'pending status)) "done") - 'debbugs-gnu-done) - ((member "pending" (cdr (assq 'keywords status))) - 'debbugs-gnu-pending) - ((= (cdr (assq 'date status)) - (cdr (assq 'log_modified status))) - 'debbugs-gnu-new) - ((< (- (float-time) - (cdr (assq 'log_modified status))) - (* 60 60 24 7 2)) - 'debbugs-gnu-handled) - (t - 'debbugs-gnu-stale))) - (propertize - ;; Prefer the name over the address. - (or (cdr address) - (car address)) - 'face - ;; Mark own submitted bugs. - (if (and (stringp (car address)) - (string-equal (car address) user-mail-address)) - 'debbugs-gnu-tagged - 'default)) - (propertize - subject - 'face - ;; Mark owned bugs. - (if (and (stringp owner) - (string-equal owner user-mail-address)) - 'debbugs-gnu-tagged - 'default)))) - 'append))))) + (dolist (status + (apply 'debbugs-get-status + (debbugs-gnu-get-bugs debbugs-gnu-current-query))) + (let* ((id (cdr (assq 'id status))) + (words + (mapconcat + 'identity + (cons (cdr (assq 'severity status)) + (cdr (assq 'keywords status))) + ",")) + (address (mail-header-parse-address + (decode-coding-string (cdr (assq 'originator status)) + 'utf-8))) + (owner (if (cdr (assq 'owner status)) + (car (mail-header-parse-address + (decode-coding-string (cdr (assq 'owner status)) + 'utf-8))))) + (subject (decode-coding-string (cdr (assq 'subject status)) + 'utf-8)) + merged) + (unless (equal (cdr (assq 'pending status)) "pending") + (setq words (concat words "," (cdr (assq 'pending status))))) + (let ((packages (delete "emacs" (cdr (assq 'package status))))) + (when packages + (setq words (concat words "," (mapconcat 'identity packages ","))))) + (when (setq merged (cdr (assq 'mergedwith status))) + (setq words (format "%s,%s" + (if (numberp merged) + merged + (mapconcat 'number-to-string merged ",")) + words))) + (when (or (not merged) + (not (let ((found nil)) + (dolist (id (if (listp merged) + merged + (list merged))) + (dolist (entry tabulated-list-entries) + (when (equal id (cdr (assq 'id (car entry)))) + (setq found t)))) + found))) + (add-to-list + 'tabulated-list-entries + (list + status + (vector + (propertize + (format "%5d" id) + 'face + ;; Mark tagged bugs. + (if (memq id debbugs-gnu-local-tags) + 'debbugs-gnu-tagged + 'default)) + (propertize + ;; Mark status and age. + words + 'face + (cond + ((cdr (assq 'archived status)) + 'debbugs-gnu-archived) + ((equal (cdr (assq 'pending status)) "done") + 'debbugs-gnu-done) + ((member "pending" (cdr (assq 'keywords status))) + 'debbugs-gnu-pending) + ((= (cdr (assq 'date status)) + (cdr (assq 'log_modified status))) + 'debbugs-gnu-new) + ((< (- (float-time) + (cdr (assq 'log_modified status))) + (* 60 60 24 7 2)) + 'debbugs-gnu-handled) + (t + 'debbugs-gnu-stale))) + (propertize + ;; Prefer the name over the address. + (or (cdr address) + (car address)) + 'face + ;; Mark own submitted bugs. + (if (and (stringp (car address)) + (string-equal (car address) user-mail-address)) + 'debbugs-gnu-tagged + 'default)) + (propertize + subject + 'face + ;; Mark owned bugs. + (if (and (stringp owner) + (string-equal owner user-mail-address)) + 'debbugs-gnu-tagged + 'default)))) + 'append)))) (tabulated-list-init-header) (tabulated-list-print) @@ -1574,4 +1553,7 @@ If given a prefix, patch in the branch directory instead." ;;; TODO: +;; * Another random thought - is it possible to implement some local +;; cache, so only changed bugs are fetched? Glenn Morris. + ;;; debbugs-gnu.el ends here diff --git a/packages/debbugs/debbugs.el b/packages/debbugs/debbugs.el index 4bfbb903c..e6333ff15 100644 --- a/packages/debbugs/debbugs.el +++ b/packages/debbugs/debbugs.el @@ -36,6 +36,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 +99,42 @@ 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-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 nil;(fboundp 'soap-invoke-async) + ;; This is soap-client 3.0. Does not work for large requests. + (apply + 'soap-invoke-async + (lambda (response &rest args) + (message "lambda\n%s" response) + (setq debbugs-soap-invoke-async-object + (append debbugs-soap-invoke-async-object (car response))) + (message "lambda1\n%s" debbugs-soap-invoke-async-object)) + nil + debbugs-wsdl debbugs-port operation-name parameters) + ;; Fallback. + (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. @@ -291,40 +331,73 @@ Example: \(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)))) + (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) + (sit-for 0.1)) + ;; Fallback. + (dolist (status (async-get res)) + (setq debbugs-soap-invoke-async-object + (append debbugs-soap-invoke-async-object status))))))) + + (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 - (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)))) + '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)))) + debbugs-soap-invoke-async-object))) (defun debbugs-get-usertag (&rest query) "Return a list of bug numbers which match QUERY. @@ -752,6 +825,7 @@ current buffer." ;;; TODO: +;; * Make `debbugs-soap-invoke-async' work with `soap-invoke-async'. ;; * SOAP interface extensions (wishlist). ;; - Server-side sorting. ;; - Regexp and/or wildcards search. -- 2.39.2