Improve debbugs menu and buffer name

[gnu-emacs-elpa] / packages / debbugs / debbugs-gnu.el

diff --git a/packages/debbugs/debbugs-gnu.el b/packages/debbugs/debbugs-gnu.el
index 316a654d15680b4d86f152ab5c7092db1f952db9..510a58ed3f43ff616dd88a133c4f53196e1c5e57 100644 (file)
--- a/packages/debbugs/debbugs-gnu.el
+++ b/packages/debbugs/debbugs-gnu.el
@@ -1,4 +1,4 @@
-;;; debbugs-gnu.el --- interface for the GNU bug tracker
+;;; debbugs-gnu.el --- interface for the GNU bug tracker  -*- lexical-binding:t -*-

 
 ;; Copyright (C) 2011-2016 Free Software Foundation, Inc.
 
 
 ;; Copyright (C) 2011-2016 Free Software Foundation, Inc.
 


@@ -141,8 +141,8 @@
 (require 'debbugs)
 (require 'tabulated-list)
 (require 'add-log)
 (require 'debbugs)
 (require 'tabulated-list)
 (require 'add-log)

-(require 'subr-x)
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'subr-x))
+(eval-when-compile (require 'cl-lib))

 
 (autoload 'article-decode-charset "gnus-art")
 (autoload 'diff-goto-source "diff-mode")
 
 (autoload 'article-decode-charset "gnus-art")
 (autoload 'diff-goto-source "diff-mode")


@@ -187,9 +187,6 @@
   :group 'debbugs
   :version "24.1")
 
   :group 'debbugs
   :version "24.1")
 

-(defvar debbugs-gnu-blocking-report 19759
-  "The ID of the current release report used to track blocking bug reports.")
-

 (defcustom debbugs-gnu-default-severities '("serious" "important" "normal")
   "*The list severities bugs are searched for.
 \"tagged\" is not a severity but marks locally tagged bugs."
 (defcustom debbugs-gnu-default-severities '("serious" "important" "normal")
   "*The list severities bugs are searched for.
 \"tagged\" is not a severity but marks locally tagged bugs."


@@ -205,6 +202,12 @@
              (const "tagged"))
   :version "24.1")
 
              (const "tagged"))
   :version "24.1")
 

+(defcustom debbugs-gnu-suppress-closed t
+  "If non-nil, don't show closed bugs."
+  :group 'debbugs-gnu
+  :type 'boolean
+  :version "25.1")
+

 (defconst debbugs-gnu-all-severities
   (mapcar 'cadr (cdr (get 'debbugs-gnu-default-severities 'custom-type)))
   "*List of all possible severities.")
 (defconst debbugs-gnu-all-severities
   (mapcar 'cadr (cdr (get 'debbugs-gnu-default-severities 'custom-type)))
   "*List of all possible severities.")


@@ -230,6 +233,7 @@
              (const "guile")
              (const "guix")
              (const "gzip")
              (const "guile")
              (const "guix")
              (const "gzip")

+             (const "hyperbole")

              (const "idutils")
              (const "libtool")
              (const "mh-e")
              (const "idutils")
              (const "libtool")
              (const "mh-e")


@@ -257,8 +261,8 @@ suppressed bugs is toggled by `debbugs-gnu-toggle-suppress'."
 
 (defcustom debbugs-gnu-mail-backend 'gnus
   "*The email backend to use for reading bug report email exchange.
 
 (defcustom debbugs-gnu-mail-backend 'gnus
   "*The email backend to use for reading bug report email exchange.

-If this is 'gnus, the default, use Gnus.
-If this is 'rmail, use Rmail instead."
+If this is `gnus', the default, use Gnus.
+If this is `rmail', use Rmail instead."

   :group 'debbugs-gnu
   :type '(choice (const :tag "Use Gnus" 'gnus)
                 (const :tag "Use Rmail" 'rmail))
   :group 'debbugs-gnu
   :type '(choice (const :tag "Use Gnus" 'gnus)
                 (const :tag "Use Rmail" 'rmail))


@@ -318,6 +322,22 @@ a date, value is the cons cell \(BEFORE . AFTER\).")
 The specification which bugs shall be suppressed is taken from
   `debbugs-gnu-default-suppress-bugs'.")
 
 The specification which bugs shall be suppressed is taken from
   `debbugs-gnu-default-suppress-bugs'.")
 

+(defcustom debbugs-gnu-emacs-current-release "25.1"
+  "The current Emacs relase developped for."
+  :group 'debbugs-gnu
+  :type '(set (const "24.5")
+             (const "25.1")
+             (const "25.2"))
+  :version "25.1")
+
+(defconst debbugs-gnu-blocking-reports
+  '(("24.5" . 19758)
+    ("25.1" . 19759)
+    ("25.2" . 21966))
+  "The IDs of the Emacs report used to track blocking bug reports.
+It is a list of cons cells, each one containing the Emacs
+version (a string) and the bug report number (a number).")
+

 (defun debbugs-gnu-calendar-read (prompt acceptable &optional initial-contents)
   "Return a string read from the minibuffer.
 Derived from `calendar-read'."
 (defun debbugs-gnu-calendar-read (prompt acceptable &optional initial-contents)
   "Return a string read from the minibuffer.
 Derived from `calendar-read'."


@@ -356,7 +376,10 @@ marked as \"client-side filter\"."
            (setq phrase nil)
          (add-to-list 'debbugs-gnu-current-query (cons 'phrase phrase)))
        ;; We suppress closed bugs if there is no phrase.
            (setq phrase nil)
          (add-to-list 'debbugs-gnu-current-query (cons 'phrase phrase)))
        ;; We suppress closed bugs if there is no phrase.

-       (setq debbugs-gnu-current-suppress (null phrase))
+       (setq debbugs-gnu-current-suppress
+             (if (not debbugs-gnu-suppress-closed)
+                 nil
+               (null phrase)))

 
        ;; The other queries.
        (catch :finished
 
        ;; The other queries.
        (catch :finished


@@ -364,13 +387,28 @@ marked as \"client-side filter\"."
            (setq key (completing-read
                       "Enter attribute: "
                       (if phrase
            (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"))
+                          (append
+                           '("severity" "package" "tags"
+                             "author" "date" "subject")
+                            ;; Client-side filters.
+                           (mapcar
+                            (lambda (key)
+                              (propertize
+                               key 'face 'debbugs-gnu-done
+                               'help-echo "Client-side filter"))
+                            '("status")))
+                        (append
+                         '("severity" "package" "archive" "src" "status" "tag"
+                           "owner" "submitter" "maint" "correspondent")
+                         ;; Client-side filters.
+                         (mapcar
+                          (lambda (key)
+                            (propertize
+                             key 'face 'debbugs-gnu-done
+                             'help-echo "Client-side filter"))
+                          '("date" "log_modified" "last_modified"
+                            "found_date" "fixed_date" "unarchived"
+                            "subject" "done" "forwarded" "msgid" "summary"))))

                       nil t))
            (cond
             ;; Server-side queries.
                       nil t))
            (cond
             ;; Server-side queries.


@@ -398,21 +436,29 @@ marked as \"client-side filter\"."
                (add-to-list
                 'debbugs-gnu-current-query (cons (intern key) val1))))
 
                (add-to-list
                 'debbugs-gnu-current-query (cons (intern key) val1))))
 

-            ((member key '("owner" "submitter" "maint" "correspondent"))
+            ((member
+              key '("author" "owner" "submitter" "maint" "correspondent"))

              (setq val1 (read-string "Enter email address: "))
              (when (not (zerop (length val1)))
                (add-to-list
              (setq val1 (read-string "Enter email address: "))
              (when (not (zerop (length val1)))
                (add-to-list

-                'debbugs-gnu-current-query (cons (intern key) val1))))
+                'debbugs-gnu-current-query
+                (cons (intern (if (equal key "author") "@author" key)) val1))))

 
 

+            ;; Client-side filters.

             ((equal key "status")
              (setq
               val1
             ((equal key "status")
              (setq
               val1

-              (completing-read "Enter status: " '("done" "forwarded" "open")))
+              (completing-read
+               (format "Enter status%s: "
+                       (if (null phrase) "" " (client-side filter)"))
+               '("open" "forwarded" "done")))

              (when (not (zerop (length val1)))
              (when (not (zerop (length val1)))

-               (add-to-list
-                'debbugs-gnu-current-query (cons (intern key) val1))))
+                (if (null phrase)
+                    (add-to-list
+                     'debbugs-gnu-current-query (cons (intern key) val1))
+                  (add-to-list
+                   'debbugs-gnu-current-filter (cons 'pending val1)))))

 
 

-            ;; Client-side filters.

             ((member key '("date" "log_modified" "last_modified"
                            "found_date" "fixed_date" "unarchived"))
              (setq val1
             ((member key '("date" "log_modified" "last_modified"
                            "found_date" "fixed_date" "unarchived"))
              (setq val1


@@ -451,12 +497,13 @@ marked as \"client-side filter\"."
                     'debbugs-gnu-current-query 'debbugs-gnu-current-filter)
                 (cons (intern key) (cons val1 val2)))))
 
                     'debbugs-gnu-current-query 'debbugs-gnu-current-filter)
                 (cons (intern key) (cons val1 val2)))))
 

+            ;; "subject", "done", "forwarded", "msgid", "summary".

             ((not (zerop (length key)))
              (setq val1
                    (funcall
                     (if phrase 'read-string 'read-regexp)
             ((not (zerop (length key)))
              (setq val1
                    (funcall
                     (if phrase 'read-string 'read-regexp)

-                    (format "Enter %s%s"
-                            key (if phrase ": " " (client-side filter)"))))
+                    (format "Enter %s%s: "
+                            key (if phrase "" " (client-side filter)"))))

              (when (not (zerop (length val1)))
                (add-to-list
                 (if phrase
              (when (not (zerop (length val1)))
                (add-to-list
                 (if phrase


@@ -469,6 +516,12 @@ marked as \"client-side filter\"."
        ;; Do the search.
        (debbugs-gnu severities packages archivedp))))
 
        ;; Do the search.
        (debbugs-gnu severities packages archivedp))))
 

+;;;###autoload
+(defun debbugs-gnu-patches ()
+  "List the bug reports that have been marked as containing a patch."
+  (interactive)
+  (debbugs-gnu nil debbugs-gnu-default-packages nil nil "patch"))
+

 ;;;###autoload
 (defun debbugs-gnu (severities &optional packages archivedp suppress tags)
   "List all outstanding bugs."
 ;;;###autoload
 (defun debbugs-gnu (severities &optional packages archivedp suppress tags)
   "List all outstanding bugs."


@@ -493,49 +546,52 @@ marked as \"client-side filter\"."
       (when (member "tagged" severities)
        (split-string (read-string "User tag(s): ") "," t)))))
 
       (when (member "tagged" severities)
        (split-string (read-string "User tag(s): ") "," t)))))
 

-  ;; Initialize variables.
-  (when (and (file-exists-p debbugs-gnu-persistency-file)
-            (not debbugs-gnu-local-tags))
-    (with-temp-buffer
-      (insert-file-contents debbugs-gnu-persistency-file)
-      (eval (read (current-buffer)))))
-  ;; Per default, we suppress retrieved unwanted bugs.
-  (when (called-interactively-p 'any)
-    (setq debbugs-gnu-current-suppress t))
-
-  ;; Add queries.
-  (dolist (severity (if (consp severities) severities (list severities)))
-    (when (not (zerop (length severity)))
-      (when (string-equal severity "tagged")
-       (setq debbugs-gnu-current-suppress nil))
-      (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
-    (setq debbugs-gnu-current-suppress nil)
-    (add-to-list 'debbugs-gnu-current-query '(archive . "1")))
-  (when suppress
-    (setq debbugs-gnu-current-suppress t)
-    (add-to-list 'debbugs-gnu-current-query '(status . "open"))
-    (add-to-list 'debbugs-gnu-current-query '(status . "forwarded")))
-  (dolist (tag (if (consp tags) tags (list tags)))
-    (when (not (zerop (length tag)))
-      (add-to-list 'debbugs-gnu-current-query (cons 'tag tag))))
-
-  ;; Show result.
-  (debbugs-gnu-show-reports)
-
-  ;; Reset query, filter and suppress.
-  (setq debbugs-gnu-current-query nil
-       debbugs-gnu-current-filter nil
-       debbugs-gnu-current-suppress nil))
+  (unwind-protect
+      (progn
+       ;; Initialize variables.
+       (when (and (file-exists-p debbugs-gnu-persistency-file)
+                  (not debbugs-gnu-local-tags))
+         (with-temp-buffer
+           (insert-file-contents debbugs-gnu-persistency-file)
+           (eval (read (current-buffer)))))
+       ;; Per default, we suppress retrieved unwanted bugs.
+       (when (and (called-interactively-p 'any)
+                  debbugs-gnu-suppress-closed)
+         (setq debbugs-gnu-current-suppress t))
+
+       ;; Add queries.
+       (dolist (severity (if (consp severities) severities (list severities)))
+         (when (not (zerop (length severity)))
+           (when (string-equal severity "tagged")
+             (setq debbugs-gnu-current-suppress nil))
+           (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
+         (setq debbugs-gnu-current-suppress nil)
+         (add-to-list 'debbugs-gnu-current-query '(archive . "1")))
+       (when suppress
+         (setq debbugs-gnu-current-suppress t)
+         (add-to-list 'debbugs-gnu-current-query '(status . "open"))
+         (add-to-list 'debbugs-gnu-current-query '(status . "forwarded")))
+       (dolist (tag (if (consp tags) tags (list tags)))
+         (when (not (zerop (length tag)))
+           (add-to-list 'debbugs-gnu-current-query (cons 'tag tag))))
+
+       ;; Show result.
+       (debbugs-gnu-show-reports))
+
+    ;; Reset query, filter and suppress.
+    (setq debbugs-gnu-current-query nil
+         debbugs-gnu-current-filter nil
+         debbugs-gnu-current-suppress nil)))

 
 (defun debbugs-gnu-get-bugs (query)
   "Retrieve bug numbers from debbugs.gnu.org according search criteria."
   (let* ((debbugs-port "gnu.org")
         (bugs (assoc 'bugs query))
 
 (defun debbugs-gnu-get-bugs (query)
   "Retrieve bug numbers from debbugs.gnu.org according search criteria."
   (let* ((debbugs-port "gnu.org")
         (bugs (assoc 'bugs query))

-        (tags (assoc 'tag query))
+        (tags (and (member '(severity . "tagged") query) (assoc 'tag query)))

         (local-tags (and (member '(severity . "tagged") query) (not tags)))
         (phrase (assoc 'phrase query))
         args)
         (local-tags (and (member '(severity . "tagged") query) (not tags)))
         (phrase (assoc 'phrase query))
         args)


@@ -583,8 +639,15 @@ marked as \"client-side filter\"."
   "Show bug reports.
 If OFFLINE is non-nil, the query is not sent to the server.  Bugs
 are taken from the cache instead."
   "Show bug reports.
 If OFFLINE is non-nil, the query is not sent to the server.  Bugs
 are taken from the cache instead."

-  (let ((inhibit-read-only t)
-       (buffer-name "*Emacs Bugs*"))
+  (let* ((inhibit-read-only t)
+        string
+        (buffer-name
+         (cond
+          ((setq string (cdr (assq 'phrase debbugs-gnu-current-query)))
+           (format "*%S Bugs*" string))
+          ((setq string (cdr (assq 'package debbugs-gnu-current-query)))
+           (format "*%s Bugs*" (capitalize string)))
+          (t "*Bugs*"))))

     ;; The tabulated mode sets several local variables.  We must get
     ;; rid of them.
     (when (get-buffer buffer-name)
     ;; The tabulated mode sets several local variables.  We must get
     ;; rid of them.
     (when (get-buffer buffer-name)


@@ -625,7 +688,10 @@ are taken from the cache instead."
             merged)
        (unless (equal (cdr (assq 'pending status)) "pending")
          (setq words (concat words "," (cdr (assq 'pending status)))))
             merged)
        (unless (equal (cdr (assq 'pending status)) "pending")
          (setq words (concat words "," (cdr (assq 'pending status)))))

-       (let ((packages (delete "emacs" (cdr (assq 'package status)))))
+       (let ((packages (cdr (assq 'package status))))
+         (dolist (elt packages)
+           (when (member elt debbugs-gnu-default-packages)
+             (setq packages (delete elt packages))))

          (when packages
            (setq words (concat words "," (mapconcat 'identity packages ",")))))
        (when (setq merged (cdr (assq 'mergedwith status)))
          (when packages
            (setq words (concat words "," (mapconcat 'identity packages ",")))))
        (when (setq merged (cdr (assq 'mergedwith status)))


@@ -666,8 +732,11 @@ are taken from the cache instead."
                'debbugs-gnu-done)
               ((member "pending" (cdr (assq 'keywords status)))
                'debbugs-gnu-pending)
                'debbugs-gnu-done)
               ((member "pending" (cdr (assq 'keywords status)))
                'debbugs-gnu-pending)

-              ((= (cdr (assq 'date status))
-                  (cdr (assq 'log_modified status)))
+              ;; For some new bugs `date' and `log_modified' may
+              ;; differ in 1 second.
+              ((< (abs (- (cdr (assq 'date status))
+                          (cdr (assq 'log_modified status))))
+                  3)

                'debbugs-gnu-new)
               ((< (- (float-time)
                      (cdr (assq 'log_modified status)))
                'debbugs-gnu-new)
               ((< (- (float-time)
                      (cdr (assq 'log_modified status)))


@@ -715,7 +784,8 @@ Used instead of `tabulated-list-print-entry'."
        (submitter        (aref cols 2))
        (submitter-length (nth 1 (aref tabulated-list-format 2)))
        (title            (aref cols 3))
        (submitter        (aref cols 2))
        (submitter-length (nth 1 (aref tabulated-list-format 2)))
        (title            (aref cols 3))

-       (title-length     (nth 1 (aref tabulated-list-format 3))))
+       ;; (title-length     (nth 1 (aref tabulated-list-format 3)))
+        )

     (when (and
           ;; We may have a narrowing in effect.
           (or (not debbugs-gnu-limit)
     (when (and
           ;; We may have a narrowing in effect.
           (or (not debbugs-gnu-limit)


@@ -777,6 +847,11 @@ Used instead of `tabulated-list-print-entry'."
       ;; Package "emacs" has been selected.
       (member '(package . "emacs") debbugs-gnu-local-query)))
 
       ;; Package "emacs" has been selected.
       (member '(package . "emacs") debbugs-gnu-local-query)))
 

+(defun debbugs-gnu-manual ()
+  "Display the Debbugs manual in Info mode."
+  (interactive)
+  (info "debbugs-ug"))
+

 (defconst debbugs-gnu-bug-triage-file
   (expand-file-name "../admin/notes/bug-triage" data-directory)
   "The \"bug-triage\" file.")
 (defconst debbugs-gnu-bug-triage-file
   (expand-file-name "../admin/notes/bug-triage" data-directory)
   "The \"bug-triage\" file.")


@@ -850,12 +925,16 @@ Used instead of `tabulated-list-print-entry'."
 
     (define-key-after menu-map [debbugs-gnu-separator2]
       '(menu-item "--") 'debbugs-gnu-bugs)
 
     (define-key-after menu-map [debbugs-gnu-separator2]
       '(menu-item "--") 'debbugs-gnu-bugs)

+    (define-key-after menu-map [debbugs-gnu-manual]
+      '(menu-item "Debbugs Manual" debbugs-gnu-manual
+                 :help "Show Debbugs Manual")
+      'debbugs-gnu-separator2)

     (define-key-after menu-map [debbugs-gnu-view-bug-triage]
       '(menu-item "Describe Bug Triage Procedure"
                  debbugs-gnu-view-bug-triage
                  :enable (debbugs-gnu-menu-map-bug-triage-enabled)
                  :help "Show procedure of triaging bugs")
     (define-key-after menu-map [debbugs-gnu-view-bug-triage]
       '(menu-item "Describe Bug Triage Procedure"
                  debbugs-gnu-view-bug-triage
                  :enable (debbugs-gnu-menu-map-bug-triage-enabled)
                  :help "Show procedure of triaging bugs")

-      'debbugs-gnu-separator2)
+      'debbugs-gnu-manual)

     map))
 
 (defun debbugs-gnu-rescan ()
     map))
 
 (defun debbugs-gnu-rescan ()


@@ -949,7 +1028,7 @@ The following commands are available:
       t)
      (t nil))))
 
       t)
      (t nil))))
 

-(defun debbugs-gnu-sort-title (s1 s2)
+(defun debbugs-gnu-sort-title (s1 _s2)

   (let ((owner (if (cdr (assq 'owner (car s1)))
                   (car (mail-header-parse-address
                         (decode-coding-string (cdr (assq 'owner (car s1)))
   (let ((owner (if (cdr (assq 'owner (car s1)))
                   (car (mail-header-parse-address
                         (decode-coding-string (cdr (assq 'owner (car s1)))


@@ -1001,9 +1080,16 @@ The following commands are available:
 (defun debbugs-gnu-show-all-blocking-reports ()
   "Narrow the display to just the reports that are blocking a release."
   (interactive)
 (defun debbugs-gnu-show-all-blocking-reports ()
   "Narrow the display to just the reports that are blocking a release."
   (interactive)

-  (let ((blockers (cdr (assq 'blockedby
-                            (car (debbugs-get-status
-                                  debbugs-gnu-blocking-report)))))
+  (let ((blockers
+        (cdr
+         (assq
+          'blockedby
+          (car
+           (debbugs-get-status
+            (cdr
+             (assoc
+              debbugs-gnu-emacs-current-release
+              debbugs-gnu-blocking-reports)))))))

        (id (debbugs-gnu-current-id t))
        (inhibit-read-only t)
        status)
        (id (debbugs-gnu-current-id t))
        (inhibit-read-only t)
        status)


@@ -1263,9 +1349,9 @@ removed instead."
            "usertag")
          nil t)
         current-prefix-arg))
            "usertag")
          nil t)
         current-prefix-arg))

-  (let* ((id (or debbugs-gnu-bug-number        ; Set on group entry.
-                (debbugs-gnu-guess-current-id)
-                (debbugs-gnu-current-id)))
+  (let* ((id (or (debbugs-gnu-current-id t)
+                debbugs-gnu-bug-number ; Set on group entry.
+                (debbugs-gnu-guess-current-id)))

         (version
          (when (member message '("close" "done"))
            (read-string
         (version
          (when (member message '("close" "done"))
            (read-string