X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/991d410402d5e928c47ef756a591735bda9ee277..c860062c7be598c8ba40e47fed4e3272945329dd:/packages/debbugs/debbugs-gnu.el diff --git a/packages/debbugs/debbugs-gnu.el b/packages/debbugs/debbugs-gnu.el index 49474badd..1115db819 100644 --- a/packages/debbugs/debbugs-gnu.el +++ b/packages/debbugs/debbugs-gnu.el @@ -25,7 +25,7 @@ ;;; Commentary: ;; This package provides an interface to bug reports which are located -;; on the GNU bug tracker debbugs.gnu.org. It's main purpose is to +;; on the GNU bug tracker debbugs.gnu.org. Its main purpose is to ;; show and manipulate bug reports from Emacs, but it could be used ;; also for other GNU projects which use the same bug tracker. @@ -222,6 +222,16 @@ Derived from `calendar-read'." (setq value (read-string prompt initial-contents))) value)) +(defconst debbugs-gnu-phrase-prompt + (propertize + "Enter search phrase: " + 'help-echo "\ +The search phrase contains words to be searched for, combined by +operators like AND, ANDNOT and OR. If there is no operator +between the words, AND is used by default. The phrase can also +be empty, in this case only the following attributes are used for +search.")) + ;;;###autoload (defun debbugs-gnu-search () "Search for Emacs bugs interactively. @@ -232,121 +242,135 @@ returned. If a key cannot be queried by a SOAP request, it is marked as \"client-side filter\"." (interactive) - ;; Reset query and filter. - (setq debbugs-gnu-current-query nil - debbugs-gnu-current-filter nil) - - (let ((date-format "\\([[:digit:]]\\{4\\}\\)-\\([[:digit:]]\\{1,2\\}\\)-\\([[:digit:]]\\{1,2\\}\\)") - key val1 val2 phrase severities packages archivedp) - - ;; Check for the phrase. - (setq phrase (read-string "Enter search phrase: ")) - (if (zerop (length phrase)) - (setq phrase nil) - (add-to-list 'debbugs-gnu-current-query (cons 'phrase phrase))) - - ;; The other queries. - (catch :finished - (while t - (setq key (completing-read - "Enter attribute: " - (if phrase - '("severity" "package" "tags" "submitter" "date" - "subject" "status") - '("severity" "package" "archive" "src" "tag" - "owner" "submitter" "maint" "correspondent" - "date" "log_modified" "last_modified" - "found_date" "fixed_date" "unarchived" - "subject" "done" "forwarded" "msgid" "summary")) - nil t)) - (cond - ;; Server-side queries. - ((equal key "severity") - (setq - severities - (completing-read-multiple - "Enter severities: " - (mapcar - 'cadr (cdr (get 'debbugs-gnu-default-severities 'custom-type))) - nil t (mapconcat 'identity debbugs-gnu-default-severities ",")))) - - ((equal key "package") - (setq - packages - (completing-read-multiple - "Enter packages: " - (mapcar - 'cadr (cdr (get 'debbugs-gnu-default-packages 'custom-type))) - nil t (mapconcat 'identity debbugs-gnu-default-packages ",")))) - - ((equal key "archive") - ;; We simplify, by assuming just archived bugs are requested. - (setq archivedp t)) - - ((member key '("src" "tag" "tags")) - (setq val1 (read-string (format "Enter %s: " key))) - (when (not (zerop (length val1))) - (add-to-list 'debbugs-gnu-current-query (cons (intern key) val1)))) - - ((member key '("owner" "submitter" "maint" "correspondent")) - (setq val1 (read-string "Enter email address: ")) - (when (not (zerop (length val1))) - (add-to-list 'debbugs-gnu-current-query (cons (intern key) val1)))) - - ;; Client-side filters. - ((member key '("date" "log_modified" "last_modified" - "found_date" "fixed_date" "unarchived")) - (setq val1 - (debbugs-gnu-calendar-read - (format "Enter %s before YYYY-MM-DD%s: " - key (if phrase "" " (client-side filter)")) - (lambda (x) - (string-match (concat "^\\(" date-format "\\|\\)$") x)))) - (if (string-match date-format val1) - (setq val1 (floor - (float-time - (encode-time - 0 0 0 - (string-to-number (match-string 3 val1)) - (string-to-number (match-string 2 val1)) - (string-to-number (match-string 1 val1)))))) - (setq val1 nil)) - (setq val2 - (debbugs-gnu-calendar-read - (format "Enter %s after YYYY-MM-DD%s: " - key (if phrase "" " (client-side filter)")) - (lambda (x) - (string-match (concat "^\\(" date-format "\\|\\)$") x)))) - (if (string-match date-format val2) - (setq val2 (floor - (float-time - (encode-time - 0 0 0 - (string-to-number (match-string 3 val2)) - (string-to-number (match-string 2 val2)) - (string-to-number (match-string 1 val2)))))) - (setq val2 nil)) - (when (or val1 val2) - (add-to-list - (if phrase 'debbugs-gnu-current-query 'debbugs-gnu-current-filter) - (cons (intern key) (cons val1 val2))))) - - ((not (zerop (length key))) - (setq val1 - (funcall - (if phrase 'read-string 'read-regexp) - (format "Enter %s%s" - key (if phrase ": " " (client-side filter)")))) - (when (not (zerop (length val1))) + (unwind-protect + (let ((date-format "\\([[:digit:]]\\{4\\}\\)-\\([[:digit:]]\\{1,2\\}\\)-\\([[:digit:]]\\{1,2\\}\\)") + key val1 val2 phrase severities packages archivedp) + + ;; Check for the phrase. + (setq phrase (read-string debbugs-gnu-phrase-prompt)) + (if (zerop (length phrase)) + (setq phrase nil) + (add-to-list 'debbugs-gnu-current-query (cons 'phrase phrase))) + + ;; The other queries. + (catch :finished + (while t + (setq key (completing-read + "Enter attribute: " + (if phrase + '("severity" "package" "tags" "submitter" "date" + "subject" "status") + '("severity" "package" "archive" "src" "tag" + "owner" "submitter" "maint" "correspondent" + "date" "log_modified" "last_modified" + "found_date" "fixed_date" "unarchived" + "subject" "done" "forwarded" "msgid" "summary")) + nil t)) + (cond + ;; Server-side queries. + ((equal key "severity") + (setq + severities + (completing-read-multiple + "Enter severities: " + (mapcar + 'cadr (cdr (get 'debbugs-gnu-default-severities 'custom-type))) + nil t + (mapconcat 'identity debbugs-gnu-default-severities ",")))) + + ((equal key "package") + (setq + packages + (completing-read-multiple + "Enter packages: " + (mapcar + 'cadr (cdr (get 'debbugs-gnu-default-packages 'custom-type))) + nil t (mapconcat 'identity debbugs-gnu-default-packages ",")))) + + ((equal key "archive") + ;; We simplify, by assuming just archived bugs are requested. + (setq archivedp t)) + + ((member key '("src" "tag" "tags")) + (setq val1 (read-string (format "Enter %s: " key))) + (when (not (zerop (length val1))) + (add-to-list + 'debbugs-gnu-current-query (cons (intern key) val1)))) + + ((member key '("owner" "submitter" "maint" "correspondent")) + (setq val1 (read-string "Enter email address: ")) + (when (not (zerop (length val1))) + (add-to-list + 'debbugs-gnu-current-query (cons (intern key) val1)))) + + ((equal key "status") + (setq + val1 + (completing-read "Enter status: " '("done" "forwarded" "open"))) + (when (not (zerop (length val1))) (add-to-list - (if phrase 'debbugs-gnu-current-query 'debbugs-gnu-current-filter) - (cons (intern key) val1)))) + 'debbugs-gnu-current-query (cons (intern key) val1)))) + + ;; Client-side filters. + ((member key '("date" "log_modified" "last_modified" + "found_date" "fixed_date" "unarchived")) + (setq val1 + (debbugs-gnu-calendar-read + (format "Enter %s before YYYY-MM-DD%s: " + key (if phrase "" " (client-side filter)")) + (lambda (x) + (string-match (concat "^\\(" date-format "\\|\\)$") x)))) + (if (string-match date-format val1) + (setq val1 (floor + (float-time + (encode-time + 0 0 0 + (string-to-number (match-string 3 val1)) + (string-to-number (match-string 2 val1)) + (string-to-number (match-string 1 val1)))))) + (setq val1 nil)) + (setq val2 + (debbugs-gnu-calendar-read + (format "Enter %s after YYYY-MM-DD%s: " + key (if phrase "" " (client-side filter)")) + (lambda (x) + (string-match (concat "^\\(" date-format "\\|\\)$") x)))) + (if (string-match date-format val2) + (setq val2 (floor + (float-time + (encode-time + 0 0 0 + (string-to-number (match-string 3 val2)) + (string-to-number (match-string 2 val2)) + (string-to-number (match-string 1 val2)))))) + (setq val2 nil)) + (when (or val1 val2) + (add-to-list + (if phrase + 'debbugs-gnu-current-query 'debbugs-gnu-current-filter) + (cons (intern key) (cons val1 val2))))) + + ((not (zerop (length key))) + (setq val1 + (funcall + (if phrase 'read-string 'read-regexp) + (format "Enter %s%s" + key (if phrase ": " " (client-side filter)")))) + (when (not (zerop (length val1))) + (add-to-list + (if phrase + 'debbugs-gnu-current-query 'debbugs-gnu-current-filter) + (cons (intern key) val1)))) + + ;; The End. + (t (throw :finished nil))))) - ;; The End. - (t (throw :finished nil))))) + ;; Do the search. + (debbugs-gnu severities packages archivedp)) - ;; Do the search. - (debbugs-gnu severities packages archivedp))) + ;; Reset query and filter. + (setq debbugs-gnu-current-query nil + debbugs-gnu-current-filter nil))) ;;;###autoload (defun debbugs-gnu (severities &optional packages archivedp suppress) @@ -437,11 +461,11 @@ marked as \"client-side filter\"." :buffer-name "*Emacs Bugs*" :bug-ids ids :query debbugs-gnu-current-query - :filter debbugs-gnu-current-filter))))) + :filter debbugs-gnu-current-filter)))) - ;; Reset query and filter. - (setq debbugs-gnu-current-query nil - debbugs-gnu-current-filter nil)) + ;; Reset query and filter. + (setq debbugs-gnu-current-query nil + debbugs-gnu-current-filter nil))) (defun debbugs-gnu-get-bugs (query) "Retrieve bugs numbers from debbugs.gnu.org according search criteria." @@ -531,55 +555,64 @@ marked as \"client-side filter\"." merged (mapconcat 'number-to-string merged ",")) words))) - (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 - ((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)) - '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))) + (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 + ((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) @@ -675,7 +708,6 @@ Used instead of `tabulated-list-print-entry'." (define-key map "\r" 'debbugs-gnu-select-report) (define-key map [mouse-1] 'debbugs-gnu-select-report) (define-key map [mouse-2] 'debbugs-gnu-select-report) - (define-key map "q" 'bury-buffer) (define-key map "s" 'debbugs-gnu-toggle-sort) (define-key map "t" 'debbugs-gnu-toggle-tag) (define-key map "d" 'debbugs-gnu-display-status) @@ -930,6 +962,7 @@ removed instead." "merge" "forcemerge" "owner" "noowner" "invalid" + "reassign" "patch" "wontfix" "moreinfo" "unreproducible" "fixed" "notabug" "pending" "help" "security" "confirmed") nil t) @@ -968,6 +1001,8 @@ removed instead." (read-string "Merge with bug #: "))) ((equal message "owner") (format "owner %d !\n" id)) + ((equal message "reassign") + (format "reassign %d %s\n" id (read-string "Package: "))) ((equal message "close") (format "close %d %s\n" id version)) ((equal message "done")