;; Michael Albinus <michael.albinus@gmx.org>
;; Keywords: comm, hypermedia, maint
;; Package: debbugs
-;; Package-Requires: ((async))
;; Version: 0.8
;; This file is not part of GNU Emacs.
(require 'tabulated-list)
(require 'add-log)
(require 'subr-x)
-(require 'async)
(eval-when-compile (require 'cl))
(autoload 'article-decode-charset "gnus-art")
"*The list severities bugs are searched for.
\"tagged\" is not a severity but marks locally tagged bugs."
;; <http://debbugs.gnu.org/Developer.html#severities>
+ ;; /ssh:debbugs:/etc/debbugs/config @gSeverityList
+ ;; We don't use "critical" and "grave".
:group 'debbugs-gnu
:type '(set (const "serious")
(const "important")
(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.
"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)
(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)
;;; 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
(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)
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.
\(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.
;;; TODO:
+;; * Make `debbugs-soap-invoke-async' work with `soap-invoke-async'.
;; * SOAP interface extensions (wishlist).
;; - Server-side sorting.
;; - Regexp and/or wildcards search.