X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/518a30e128e4035c02385178501f60d5686f97bd..e7d3fea3ff81ae402a5c5ab33bc16c4630b5b459:/packages/debbugs/debbugs.el diff --git a/packages/debbugs/debbugs.el b/packages/debbugs/debbugs.el index 158390a2a..1d3812ee9 100644 --- a/packages/debbugs/debbugs.el +++ b/packages/debbugs/debbugs.el @@ -98,22 +98,34 @@ This corresponds to the Debbugs server to be accessed, either (defun debbugs-get-bugs (&rest query) "Return a list of bug numbers which match QUERY. -QUERY is a keyword value sequence, whereby the values are strings. -All queries are concatenated via AND. +QUERY is a sequence of keyword-value pairs where the values are +strings, i. e. :KEYWORD \"VALUE\" [:KEYWORD \"VALUE\"]* + +The keyword-value pair is a subquery. The keywords are allowed to +have multiple occurrence within the query at any place. The +subqueries with the same keyword form the logical subquery, which +returns the union of bugs of every subquery it contains. + +The result of the QUERY is an intersection of results of all +subqueries. Valid keywords are: :package -- The value is the name of the package a bug belongs to, like \"emacs\", \"coreutils\", \"gnus\", or \"tramp\". - :severity -- This is the severity of the bug. Currently, - there exists the severities \"important\", \"grave\", - \"normal\", \"minor\" and \"wishlist\". + :src -- This is used to retrieve bugs that belong to source + with given name. + + :severity -- This is the severity of the bug. The exact set of + allowed values depends on the Debbugs port. Examples are + \"normal\", \"minor\", \"wishlist\" etc. :tag -- An arbitrary string the bug is annotated with. Usually, this is used to mark the status of the bug, like \"fixed\", \"moreinfo\", \"notabug\", \"patch\", - \"unreproducible\" or \"wontfix\". + \"unreproducible\" or \"wontfix\". The exact set of tags + depends on the Debbugs port. :owner -- This is used to identify bugs by the owner's email address. The special email address \"me\" is used as pattern, @@ -123,50 +135,78 @@ Valid keywords are: by the submitter's email address. The special email address \"me\" is used as pattern, replaced with `user-mail-address'. + :maint -- This is used to find bugs of the packages which are + maintained by the person with the given email address. The + special email address \"me\" is used as pattern, replaced with + `user-mail-address'. + + :correspondent -- This allows to find bug reports where the + person with the given email address has participated. The + special email address \"me\" is used as pattern, replaced with + `user-mail-address'. + + :affects -- With this keyword it is possible to find bugs which + affect the package with the given name. The bugs are chosen by + 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\". + :archive -- A keyword to filter for bugs which are already archived, or not. Valid values are \"0\" (not archived), \"1\" (archived) or \"both\". If this keyword is not given in the query, `:archive \"0\"' is assumed by default. -Example: +Example. Get all opened and forwarded release critical bugs for +the packages which are maintained by \"me\" and which have a +patch: - \(debbugs-get-bugs :submitter \"me\" :archive \"both\") - => \(5516 5551 5645 7259)" + \(debbugs-get-bugs :maint \"me\" :tag \"patch\" + :severity \"critical\" + :status \"open\" + :severity \"grave\" + :status \"forwarded\" + :severity \"serious\"))" - (let (vec key val) + (let (vec kw key val) ;; Check query. (while (and (consp query) (<= 2 (length query))) - (setq key (pop query) - val (pop query) - vec (vconcat vec (list (substring (symbol-name key) 1)))) - (unless (and (keywordp key) (stringp val)) - (error "Wrong query: %s %s" key val)) - (case key - ((:package :severity :tag) + (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 :severity :tag :src :affects) ;; Value shall be one word. - (if (string-match "\\`[A-Za-z]+\\'" val) - (setq vec (vconcat vec (list val))) - (error "Wrong %s: %s" (car (last vec)) val))) - ;; Value is an email address. - ((:owner :submitter) + (if (string-match "\\`\\S-+\\'" val) + (setq vec (vconcat vec (list key val))) + (error "Wrong %s: %s" key val))) + ((:owner :submitter :maint :correspondent) + ;; Value is an email address. (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))) - (setq vec (vconcat vec (list val)))) - (error "Wrong %s: %s" (car (last vec)) val))) + (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) + (setq vec (vconcat vec (list key val))) + (error "Wrong %s: %s" key val))) (:archive ;; Value is `0' or `1' or `both'. (if (string-match "\\`\\(0\\|1\\|both\\)\\'" val) - (setq vec (vconcat vec (list val))) - (error "Wrong %s: %s" (car (last vec)) val))) - (t (error "Unknown key: %s" (car (last vec)))))) + (setq vec (vconcat vec (list key val))) + (error "Wrong %s: %s" key val))) + (t (error "Unknown key: %s" kw)))) (unless (null query) (error "Unknown key: %s" (car query))) - (sort (car (soap-invoke debbugs-wsdl debbugs-port "get_bugs" vec)) '<))) (defun debbugs-newest-bugs (amount) @@ -373,199 +413,6 @@ buffer." (url-copy-file url filename t) (url-insert-file-contents url)))) -;; Interface for the Emacs bug tracker. - -(autoload 'gnus-read-ephemeral-emacs-bug-group "gnus-group") -(autoload 'mail-header-subject "nnheader") -(autoload 'gnus-summary-article-header "gnus-sum") -(autoload 'message-make-from "message") - -(defface debbugs-new '((t (:foreground "red"))) - "Face for new reports that nobody has answered.") - -(defface debbugs-handled '((t (:foreground "ForestGreen"))) - "Face for new reports that nobody has answered.") - -(defface debbugs-stale '((t (:foreground "orange"))) - "Face for new reports that nobody has answered.") - -(defface debbugs-done '((t (:foreground "DarkGrey"))) - "Face for closed bug reports.") - -(defun debbugs-emacs (severities &optional package list-done archivedp) - "List all outstanding Emacs bugs." - (interactive - (list - (completing-read "Severity: " - '("important" "normal" "minor" "wishlist") - nil t "normal"))) - (unless (consp severities) - (setq severities (list severities))) - (pop-to-buffer (get-buffer-create "*Emacs Bugs*")) - (debbugs-mode) - (let ((debbugs-port "gnu.org") - (buffer-read-only nil) - (ids nil) - (default 400)) - (dolist (severity severities) - (setq ids (nconc ids - (debbugs-get-bugs :package (or package "emacs") - :severity severity - :archive (if archivedp - "1" "0"))))) - (erase-buffer) - - (when (> (length ids) default) - (let* ((cursor-in-echo-area nil) - (input - (read-string - (format - "How many reports (available %d, default %d): " - (length ids) default) - nil - nil - (number-to-string default)))) - (setq ids (last (sort ids '<) (string-to-number input))))) - - (dolist (status (sort (apply 'debbugs-get-status ids) - (lambda (s1 s2) - (< (cdr (assq 'id s1)) - (cdr (assq 'id s2)))))) - (when (or list-done - (not (equal (cdr (assq 'pending status)) "done"))) - (let ((address (mail-header-parse-address - (decode-coding-string (cdr (assq 'originator status)) - 'utf-8)))) - (setq address - ;; Prefer the name over the address. - (or (cdr address) - (car address))) - (insert - (format "%5d %-20s [%-23s] %s\n" - (cdr (assq 'id status)) - (let ((words - (mapconcat - 'identity - (cons (cdr (assq 'severity status)) - (cdr (assq 'keywords status))) - ","))) - (unless (equal (cdr (assq 'pending status)) "pending") - (setq words (concat words "," (cdr (assq 'pending status))))) - (if (> (length words) 20) - (substring words 0 20) - words)) - (if (> (length address) 23) - (substring address 0 23) - address) - (decode-coding-string (cdr (assq 'subject status)) - 'utf-8))) - (forward-line -1) - (put-text-property - (+ (point) 5) (+ (point) 26) - 'face - (cond - ((equal (cdr (assq 'pending status)) "done") - 'debbugs-done) - ((= (cdr (assq 'date status)) - (cdr (assq 'log_modified status))) - 'debbugs-new) - ((< (- (float-time) - (cdr (assq 'log_modified status))) - (* 60 60 24 4)) - 'debbugs-handled) - (t - 'debbugs-stale))) - (forward-line 1))))) - (goto-char (point-min))) - -(defvar debbugs-mode-map nil) -(unless debbugs-mode-map - (setq debbugs-mode-map (make-sparse-keymap)) - (define-key debbugs-mode-map "\r" 'debbugs-select-report)) - -(defun debbugs-mode () - "Major mode for listing bug reports. - -All normal editing commands are switched off. -\\ - -The following commands are available: - -\\{debbugs-mode-map}" - (interactive) - (kill-all-local-variables) - (setq major-mode 'debbugs-mode) - (setq mode-name "Debbugs") - (use-local-map debbugs-mode-map) - (buffer-disable-undo) - (setq truncate-lines t) - (setq buffer-read-only t)) - -(defun debbugs-select-report () - "Select the report on the current line." - (interactive) - (let (id) - (save-excursion - (beginning-of-line) - (if (not (looking-at " *\\([0-9]+\\)")) - (error "No bug report on the current line") - (setq id (string-to-number (match-string 1))))) - (gnus-read-ephemeral-emacs-bug-group - id (cons (current-buffer) - (current-window-configuration))) - (with-current-buffer (window-buffer (selected-window)) - (debbugs-summary-mode 1)))) - -(defvar debbugs-summary-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "C" 'debbugs-send-control-message) - map)) - -(define-minor-mode debbugs-summary-mode - "Minor mode for providing a debbugs interface in Gnus summary buffers. - -\\{debbugs-summary-mode-map}" - :lighter " Debbugs" :keymap debbugs-summary-mode-map - nil) - -(defun debbugs-send-control-message (message) - "Send a control message for the current bug report. -You can set the severity or add a tag, or close the report. If -you use the special \"done\" MESSAGE, the report will be marked as -fixed, and then closed." - (interactive - (list (completing-read - "Control message: " - '("important" "normal" "minor" "wishlist" - "done" - "unarchive" "reopen" "close" - "merge" "forcemerge" - "patch" "wontfix" "moreinfo" "unreproducible" "fixed" "notabug") - nil t))) - (let* ((subject (mail-header-subject (gnus-summary-article-header))) - (id - (if (string-match "bug#\\([0-9]+\\)" subject) - (string-to-number (match-string 1 subject)) - (error "No bug number present")))) - (with-temp-buffer - (insert "To: control@debbugs.gnu.org\n" - "From: " (message-make-from) "\n" - (format "Subject: control message for bug #%d\n" id) - "\n" - (cond - ((member message '("unarchive" "reopen" "close")) - (format "%s %d\n" message id)) - ((member message '("merge" "forcemerge")) - (format "%s %d %s\n" message id - (read-string "Merge with bug #: "))) - ((equal message "done") - (format "tags %d fixed\nclose %d\n" id id)) - ((member message '("important" "normal" "minor" "wishlist")) - (format "severity %d %s\n" id message)) - (t - (format "tags %d %s\n" id message)))) - (funcall send-mail-function)))) - (provide 'debbugs) ;;; TODO: @@ -575,8 +422,5 @@ fixed, and then closed." ;; - Regexp and/or wildcards search. ;; - Fulltext search. ;; - Returning message attachments. -;; * Widget-oriented bug overview like webDDTs. -;; * Actions on bugs. -;; * Integration into gnus (nnir). ;;; debbugs.el ends here