X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/afb11d7fdfeb6f9421e3cd63a197d6b202cff81e..c860062c7be598c8ba40e47fed4e3272945329dd:/packages/debbugs/debbugs-gnu.el diff --git a/packages/debbugs/debbugs-gnu.el b/packages/debbugs/debbugs-gnu.el index c42e11516..1115db819 100644 --- a/packages/debbugs/debbugs-gnu.el +++ b/packages/debbugs/debbugs-gnu.el @@ -5,7 +5,7 @@ ;; Author: Lars Magne Ingebrigtsen ;; Keywords: comm, hypermedia, maint ;; Package: debbugs -;; Version: 0.1 +;; Version: 0.3 ;; This file is part of GNU Emacs. @@ -25,14 +25,15 @@ ;;; 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. ;; If you have `debbugs-gnu.el' in your load-path, you could enable -;; the bug tracker command by the following line in your ~/.emacs +;; the bug tracker command by the following lines in your ~/.emacs ;; ;; (autoload 'debbugs-gnu "debbugs-gnu" "" 'interactive) +;; (autoload 'debbugs-gnu-search "debbugs-gnu" "" 'interactive) ;; The bug tracker is called interactively by ;; @@ -57,11 +58,14 @@ ;; ;; M-x debbugs-gnu-search -;; It behaves like `debbugs-gnu', additionally it asks for key-value -;; pairs to filter bugs. Keys are as described in +;; It behaves like `debbugs-gnu', but asks at the beginning for a +;; search phrase to be used for full text search. Additionally, it +;; asks for key-value pairs to filter bugs. Keys are as described in ;; `debbugs-get-status', the corresponding value must be a regular -;; expression to match for. The other parameters are as described -;; in `debbugs-gnu'. +;; expression to match for. The other parameters are as described in +;; `debbugs-gnu'. Usually, there is just one value except for the +;; attribute "date", which needs two arguments specifying a period in +;; which the bug has been submitted or modified. ;; The bug reports are downloaded from the bug tracker. In order to ;; not generate too much load of the server, up to 500 bugs will be @@ -149,7 +153,8 @@ "*A list of specs for bugs to be suppressed. An element of this list is a cons cell \(KEY . REGEXP\), with key being returned by `debbugs-get-status', and VAL a regular -expression matchin the corresponding value, a string." +expression matching the corresponding value, a string. Showing +suppressed bugs is toggled by `debbugs-gnu-toggle-suppress'." :group 'debbugs-gnu :type '(alist :key-type symbol :value-type regexp) :version "24.1") @@ -198,44 +203,183 @@ expression matchin the corresponding value, a string." (sort (copy-sequence debbugs-gnu-local-tags) '<))))) (defvar debbugs-gnu-current-query nil - "The query object of the current search.") - -(defvar debbugs-gnu-current-severities nil - "The severities strings to be searched for.") - -(defvar debbugs-gnu-current-packages nil - "The package names to be searched for.") - -(defvar debbugs-gnu-current-archive nil - "Whether to search in the archive.") - -(defun debbugs-gnu-search - (query &optional severities packages archivedp suppress) - "Search for Emacs bugs interactively." - (interactive - (list - (let ((continue t) - key val query) - (while continue - (setq key (read-string "Enter attribute: ") - val (when (not (zerop (length key))) - (read-regexp "Enter regexp"))) - (if (and (not (zerop (length key))) (not (zerop (length val)))) - (add-to-list 'query (cons (intern key) val)) - (setq continue nil))) - query))) - (setq debbugs-gnu-current-query query) - (if (called-interactively-p 'interactive) - (call-interactively 'debbugs-gnu) - (debbugs-gnu severities packages archivedp suppress))) + "The query object of the current search. +It will be applied server-side, when calling `debbugs-get-bugs'. +It has the same format as `debbugs-gnu-default-suppress-bugs'.") + +(defvar debbugs-gnu-current-filter nil + "The filter object for the current search. +It will be applied client-side, when parsing the results of +`debbugs-get-status'. It has a similar format as +`debbugs-gnu-default-suppress-bugs'. In case of keys representing +a date, value is the cons cell \(BEFORE . AFTER\).") + +(defun debbugs-gnu-calendar-read (prompt acceptable &optional initial-contents) + "Return a string read from the minibuffer. +Derived from `calendar-read'." + (let ((value (read-string prompt initial-contents))) + (while (not (funcall acceptable value)) + (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. +Search arguments are requested interactively. The \"search +phrase\" is used for full text search in the bugs database. +Further key-value pairs are requested until an empty key is +returned. If a key cannot be queried by a SOAP request, it is +marked as \"client-side filter\"." + (interactive) + (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 + '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))))) + + ;; 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) "List all outstanding Emacs bugs." (interactive (let (archivedp) (list (completing-read-multiple - "Severity: " + "Severities: " (mapcar 'cadr (cdr (get 'debbugs-gnu-default-severities 'custom-type))) nil t (mapconcat 'identity debbugs-gnu-default-severities ",")) ;; The optional parameters are asked only when there is a prefix. @@ -256,76 +400,116 @@ expression matchin the corresponding value, a string." (with-temp-buffer (insert-file-contents debbugs-gnu-persistency-file) (eval (read (current-buffer))))) - ;; Set lists. - (unless (consp severities) - (setq severities (list severities))) - (unless (consp packages) - (setq packages (list packages))) - - (setq debbugs-gnu-current-severities severities - debbugs-gnu-current-packages packages - debbugs-gnu-current-archive (if archivedp "1" "0") - debbugs-gnu-widgets nil) - - (let ((hits debbugs-gnu-default-hits-per-page) - (ids (debbugs-gnu-get-bugs))) - - (if (> (length ids) hits) - (let ((cursor-in-echo-area nil)) - (setq hits - (string-to-number - (read-string - (format - "How many reports (available %d, default %d): " - (length ids) hits) - nil - nil - (number-to-string hits)))))) - - (if (> (length ids) hits) - (let ((i 0) - curr-ids) - (while ids - (setq i (1+ i) - curr-ids (butlast ids (- (length ids) hits))) - (add-to-list - 'debbugs-gnu-widgets - (widget-convert - 'push-button - :follow-link 'mouse-face - :notify (lambda (widget &rest ignore) - (debbugs-gnu-show-reports widget)) - :keymap debbugs-gnu-widget-map - :suppress suppress - :buffer-name (format "*Emacs Bugs*<%d>" i) - :bug-ids curr-ids - :help-echo (format "%d-%d" (car ids) (car (last curr-ids))) - :format " %[%v%]" - (number-to-string i)) - 'append) - (setq ids (last ids (- (length ids) hits)))) - (debbugs-gnu-show-reports (car debbugs-gnu-widgets))) - - (debbugs-gnu-show-reports - (widget-convert - 'const - :suppress suppress - :buffer-name "*Emacs Bugs*" - :bug-ids ids))))) - -(defun debbugs-gnu-get-bugs () + (setq debbugs-gnu-widgets nil) + + ;; Add queries. + (dolist (severity (if (consp severities) severities (list severities))) + (when (not (zerop (length severity))) + (add-to-list 'debbugs-gnu-current-query (cons 'severity severity)))) + (dolist (package (if (consp packages) packages (list packages))) + (when (not (zerop (length package))) + (add-to-list 'debbugs-gnu-current-query (cons 'package package)))) + (when archivedp + (add-to-list 'debbugs-gnu-current-query '(archive . "1"))) + + (unwind-protect + (let ((hits debbugs-gnu-default-hits-per-page) + (ids (debbugs-gnu-get-bugs debbugs-gnu-current-query))) + + (if (> (length ids) hits) + (let ((cursor-in-echo-area nil)) + (setq hits + (string-to-number + (read-string + (format + "How many reports (available %d, default %d): " + (length ids) hits) + nil + nil + (number-to-string hits)))))) + + (if (> (length ids) hits) + (let ((i 0) + curr-ids) + (while ids + (setq i (1+ i) + curr-ids (butlast ids (- (length ids) hits))) + (add-to-list + 'debbugs-gnu-widgets + (widget-convert + 'push-button + :follow-link 'mouse-face + :notify (lambda (widget &rest ignore) + (debbugs-gnu-show-reports widget)) + :keymap debbugs-gnu-widget-map + :suppress suppress + :buffer-name (format "*Emacs Bugs*<%d>" i) + :bug-ids curr-ids + :query debbugs-gnu-current-query + :filter debbugs-gnu-current-filter + :help-echo (format "%d-%d" (car ids) (car (last curr-ids))) + :format " %[%v%]" + (number-to-string i)) + 'append) + (setq ids (last ids (- (length ids) hits)))) + (debbugs-gnu-show-reports (car debbugs-gnu-widgets))) + + (debbugs-gnu-show-reports + (widget-convert + 'const + :suppress suppress + :buffer-name "*Emacs Bugs*" + :bug-ids ids + :query debbugs-gnu-current-query + :filter debbugs-gnu-current-filter)))) + + ;; 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." (let ((debbugs-port "gnu.org") - (args `(:archive ,debbugs-gnu-current-archive)) - (ids (when (member "tagged" debbugs-gnu-current-severities) - (copy-sequence debbugs-gnu-local-tags)))) - (dolist (severity (delete "tagged" debbugs-gnu-current-severities)) - (when (not (zerop (length severity))) - (setq args (append args `(:severity ,severity))))) - (dolist (package debbugs-gnu-current-packages) - (when (not (zerop (length package))) - (setq args (append args `(:package ,package))))) - (sort (nconc ids (apply 'debbugs-get-bugs args)) '<))) + (tagged (when (member '(severity . "tagged") query) + (copy-sequence debbugs-gnu-local-tags))) + (phrase (assoc 'phrase query)) + args) + ;; Compile query arguments. + (unless query + (dolist (elt debbugs-gnu-default-packages) + (setq args (append args (list :package elt))))) + (dolist (elt query) + (unless (equal elt '(severity . "tagged")) + (setq args + (append + args + (if phrase + (cond + ((eq (car elt) 'phrase) + (list (list :phrase (cdr elt) :max 500))) + ((eq (car elt) 'date) + (list (list :date (cddr elt) (cadr elt) + :operator "NUMBT"))) + (t + (list (list (intern (concat ":" (symbol-name (car elt)))) + (cdr elt) :operator "ISTRINC")))) + (list (intern (concat ":" (symbol-name (car elt)))) + (cdr elt))))))) + + (cond + ;; If the query contains only the pseudo-severity "tagged", we + ;; return just the local tagged bugs. + ((and tagged (not (memq :severity args))) + (sort tagged '<)) + ;; A full text query. + (phrase + (append + (mapcar + (lambda (x) (cdr (assoc "id" x))) + (apply 'debbugs-search-est args)) + tagged)) + ;; Otherwise, we retrieve the bugs from the server. + (t (sort (append (apply 'debbugs-get-bugs args) tagged) '<))))) (defvar debbugs-gnu-current-widget nil) @@ -371,55 +555,64 @@ expression matchin the corresponding value, a string." 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) @@ -470,12 +663,20 @@ Used instead of `tabulated-list-print-entry'." (throw :suppress t)))))) ;; Filter search list. (not (catch :suppress - (dolist (check debbugs-gnu-current-query) - (when (not - (string-match - (cdr check) - (or (cdr (assq (car check) list-id)) ""))) - (throw :suppress t)))))) + (dolist (check + (widget-get debbugs-gnu-current-widget :filter)) + (let ((val (cdr (assq (car check) list-id)))) + (if (stringp (cdr check)) + ;; Regular expression. + (when (not (string-match (cdr check) (or val ""))) + (throw :suppress t)) + ;; Time value. + (when (or (and (numberp (cadr check)) + (< (cadr check) val)) + (and (numberp (cddr check)) + (> (cddr check) val))) + (throw :suppress t)))))))) + ;; Insert id. (indent-to (- id-length (length id))) (insert id) @@ -507,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) @@ -527,7 +727,8 @@ Used instead of `tabulated-list-print-entry'." (let ((first-id (car (widget-get debbugs-gnu-current-widget :bug-ids))) (last-id (car (last (widget-get debbugs-gnu-current-widget :bug-ids)))) - (ids (debbugs-gnu-get-bugs))) + (ids (debbugs-gnu-get-bugs + (widget-get debbugs-gnu-current-widget :query)))) (while (and (<= first-id last-id) (not (memq first-id ids))) (setq first-id (1+ first-id))) @@ -733,7 +934,7 @@ The following commands are available: ;; `message-simplify-subject'. So we cannot use m-s-s. (setq subject ,debbugs-gnu-subject)))))))) -(defun debbugs-guess-current-id () +(defun debbugs-gnu-guess-current-id () "Guess the ID based on \"#23\"." (save-excursion (beginning-of-line) @@ -761,12 +962,13 @@ removed instead." "merge" "forcemerge" "owner" "noowner" "invalid" + "reassign" "patch" "wontfix" "moreinfo" "unreproducible" "fixed" "notabug" "pending" "help" "security" "confirmed") nil t) current-prefix-arg)) (let* ((id (or debbugs-gnu-bug-number ; Set on group entry. - (debbugs-guess-current-id) + (debbugs-gnu-guess-current-id) (debbugs-gnu-current-id))) (version (when (member message '("close" "done")) @@ -799,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") @@ -822,4 +1026,6 @@ removed instead." ;;; TODO: +;; * Reorganize pages after client-side filtering. + ;;; debbugs-gnu.el ends here