Fix bug face for newly arrived bugs in debbugs-gnu.el

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

diff --git a/packages/debbugs/debbugs-gnu.el b/packages/debbugs/debbugs-gnu.el
index 392934800774838b10ed1e5aa4476afea93161ab..dd1fe3346f28529534649ccb4abf68b5c868c6a2 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,13 +141,14 @@
 (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 'diff-hunk-file-names "diff-mode")
 (autoload 'gnus-article-mime-handles "gnus-art")
 
 (autoload 'article-decode-charset "gnus-art")
 (autoload 'diff-goto-source "diff-mode")
 (autoload 'diff-hunk-file-names "diff-mode")
 (autoload 'gnus-article-mime-handles "gnus-art")

+(autoload 'gnus-fetch-field "gnus-util")

 (autoload 'gnus-read-ephemeral-emacs-bug-group "gnus-group")
 (autoload 'gnus-summary-article-header "gnus-sum")
 (autoload 'gnus-summary-select-article "gnus-sum")
 (autoload 'gnus-read-ephemeral-emacs-bug-group "gnus-group")
 (autoload 'gnus-summary-article-header "gnus-sum")
 (autoload 'gnus-summary-select-article "gnus-sum")


@@ -204,6 +205,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.2")
+

 (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.")


@@ -276,7 +283,7 @@ If this is 'rmail, use Rmail instead."
   "Face for reports that are pending.")
 
 (defface debbugs-gnu-stale '((t (:foreground "orange")))
   "Face for reports that are pending.")
 
 (defface debbugs-gnu-stale '((t (:foreground "orange")))

-  "Face for reports that have not been touched for a week.")
+  "Face for reports that have not been touched for two weeks.")

 
 (defface debbugs-gnu-done '((t (:foreground "DarkGrey")))
   "Face for closed bug reports.")
 
 (defface debbugs-gnu-done '((t (:foreground "DarkGrey")))
   "Face for closed bug reports.")


@@ -335,6 +342,12 @@ 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."))
 
 be empty, in this case only the following attributes are used for
 search."))
 

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

 ;;;###autoload
 (defun debbugs-gnu-search ()
   "Search for Emacs bugs interactively.
 ;;;###autoload
 (defun debbugs-gnu-search ()
   "Search for Emacs bugs interactively.


@@ -355,7 +368,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


@@ -499,7 +515,8 @@ marked as \"client-side filter\"."
       (insert-file-contents debbugs-gnu-persistency-file)
       (eval (read (current-buffer)))))
   ;; Per default, we suppress retrieved unwanted bugs.
       (insert-file-contents debbugs-gnu-persistency-file)
       (eval (read (current-buffer)))))
   ;; Per default, we suppress retrieved unwanted bugs.

-  (when (called-interactively-p 'any)
+  (when (and (called-interactively-p 'any)
+            debbugs-gnu-suppress-closed)

     (setq debbugs-gnu-current-suppress t))
 
   ;; Add queries.
     (setq debbugs-gnu-current-suppress t))
 
   ;; Add queries.


@@ -571,15 +588,13 @@ marked as \"client-side filter\"."
       (mapcar
        (lambda (x) (cdr (assoc "id" x)))
        (apply 'debbugs-search-est args)))
       (mapcar
        (lambda (x) (cdr (assoc "id" x)))
        (apply 'debbugs-search-est args)))

-     ;; User tags.
-     (tags
-      (setq args (mapcar (lambda (x) (if (eq x :package) :user x)) args))
-      (apply 'debbugs-get-usertag args))

      ;; Otherwise, we retrieve the bugs from the server.
      (t (apply 'debbugs-get-bugs args)))))
 
      ;; Otherwise, we retrieve the bugs from the server.
      (t (apply 'debbugs-get-bugs args)))))
 

-(defun debbugs-gnu-show-reports ()
-  "Show bug reports."
+(defun debbugs-gnu-show-reports (&optional offline)
+  "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*"))
     ;; The tabulated mode sets several local variables.  We must get
   (let ((inhibit-read-only t)
        (buffer-name "*Emacs Bugs*"))
     ;; The tabulated mode sets several local variables.  We must get


@@ -591,8 +606,16 @@ marked as \"client-side filter\"."
 
     ;; Print bug reports.
     (dolist (status
 
     ;; Print bug reports.
     (dolist (status

-            (apply 'debbugs-get-status
-                   (debbugs-gnu-get-bugs debbugs-gnu-local-query)))
+            (let ((debbugs-cache-expiry (if offline nil debbugs-cache-expiry))
+                  ids)
+              (apply 'debbugs-get-status
+                     (if offline
+                         (progn
+                           (maphash (lambda (key _elem)
+                                      (push key ids))
+                                    debbugs-cache-data)
+                           (sort ids '<))
+                       (debbugs-gnu-get-bugs debbugs-gnu-local-query)))))

       (let* ((id (cdr (assq 'id status)))
             (words
              (mapconcat
       (let* ((id (cdr (assq 'id status)))
             (words
              (mapconcat


@@ -655,8 +678,11 @@ marked as \"client-side filter\"."
                '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)))


@@ -704,7 +730,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)


@@ -938,7 +965,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)))


@@ -1224,6 +1251,9 @@ MERGED is the list of bugs merged with this one."
           (re-search-forward "#\\([0-9]+\\)" nil t)))
      (string-to-number (match-string 1)))))
 
           (re-search-forward "#\\([0-9]+\\)" nil t)))
      (string-to-number (match-string 1)))))
 

+(defvar debbugs-gnu-send-mail-function nil
+  "A function to send control messages from debbugs.")
+

 (defun debbugs-gnu-send-control-message (message &optional reverse)
   "Send a control message for the current bug report.
 You can set the severity or add a tag, or close the report.  If
 (defun debbugs-gnu-send-control-message (message &optional reverse)
   "Send a control message for the current bug report.
 You can set the severity or add a tag, or close the report.  If


@@ -1243,14 +1273,15 @@ removed instead."
            "owner" "noowner"
            "invalid"
            "reassign"
            "owner" "noowner"
            "invalid"
            "reassign"

+           "retitle"

            "patch" "wontfix" "moreinfo" "unreproducible" "fixed" "notabug"
            "pending" "help" "security" "confirmed"
            "usertag")
          nil t)
         current-prefix-arg))
            "patch" "wontfix" "moreinfo" "unreproducible" "fixed" "notabug"
            "pending" "help" "security" "confirmed"
            "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


@@ -1274,6 +1305,7 @@ removed instead."
       (insert "To: control@debbugs.gnu.org\n"
              "From: " (message-make-from) "\n"
              (format "Subject: control message for bug #%d\n" id)
       (insert "To: control@debbugs.gnu.org\n"
              "From: " (message-make-from) "\n"
              (format "Subject: control message for bug #%d\n" id)

+             mail-header-separator

              "\n"
              (cond
               ((member message '("unarchive" "unmerge" "reopen" "noowner"))
              "\n"
              (cond
               ((member message '("unarchive" "unmerge" "reopen" "noowner"))


@@ -1295,6 +1327,8 @@ removed instead."
                  " ")))
               ((equal message "owner")
                (format "owner %d !\n" id))
                  " ")))
               ((equal message "owner")
                (format "owner %d !\n" id))

+              ((equal message "retitle")
+               (format "retitle %d %s\n" id (read-string "New title: ")))

               ((equal message "reassign")
                (format "reassign %d %s\n" id (read-string "Package(s): ")))
               ((equal message "close")
               ((equal message "reassign")
                (format "reassign %d %s\n" id (read-string "Package(s): ")))
               ((equal message "close")


@@ -1322,7 +1356,7 @@ removed instead."
                (format "tags %d%s %s\n"
                        id (if reverse " -" "")
                        message))))
                (format "tags %d%s %s\n"
                        id (if reverse " -" "")
                        message))))

-      (funcall send-mail-function)
+      (funcall (or debbugs-gnu-send-mail-function send-mail-function))

       (remhash id debbugs-cache-data)
       (message-goto-body)
       (message "Control message sent:\n%s"
       (remhash id debbugs-cache-data)
       (message-goto-body)
       (message "Control message sent:\n%s"


@@ -1458,7 +1492,7 @@ If given a prefix, patch in the branch directory instead."
     ;; buffer.  Determine which.
     (gnus-with-article-buffer
       (dolist (handle (mapcar 'cdr (gnus-article-mime-handles)))
     ;; buffer.  Determine which.
     (gnus-with-article-buffer
       (dolist (handle (mapcar 'cdr (gnus-article-mime-handles)))

-       (when (string-match "diff\\|patch" (mm-handle-media-type handle))
+       (when (string-match "diff\\|patch\\|plain" (mm-handle-media-type handle))

          (push (cons (mm-handle-encoding handle)
                      (mm-handle-buffer handle))
                patch-buffers))))
          (push (cons (mm-handle-encoding handle)
                      (mm-handle-buffer handle))
                patch-buffers))))


@@ -1467,11 +1501,11 @@ If given a prefix, patch in the branch directory instead."
       (article-decode-charset)
       (push (cons nil gnus-article-buffer) patch-buffers))
     (dolist (elem patch-buffers)
       (article-decode-charset)
       (push (cons nil gnus-article-buffer) patch-buffers))
     (dolist (elem patch-buffers)

-      (with-temp-buffer
+      (with-current-buffer (generate-new-buffer "*debbugs input patch*")

        (insert-buffer-substring (cdr elem))
        (cond ((eq (car elem) 'base64)
               (base64-decode-region (point-min) (point-max)))
        (insert-buffer-substring (cdr elem))
        (cond ((eq (car elem) 'base64)
               (base64-decode-region (point-min) (point-max)))

-             ((eq (car elem) 'qp)
+             ((eq (car elem) 'quoted-printable)

               (quoted-printable-decode-region (point-min) (point-max))))
        (debbugs-gnu-fix-patch dir)
        (call-process-region (point-min) (point-max)
               (quoted-printable-decode-region (point-min) (point-max))))
        (debbugs-gnu-fix-patch dir)
        (call-process-region (point-min) (point-max)


@@ -1556,18 +1590,48 @@ If given a prefix, patch in the branch directory instead."
     (message "%s is a contributor %d times" string found)
     found))
 
     (message "%s is a contributor %d times" string found)
     found))
 

+(defvar debbugs-gnu-patch-subject nil)
+

 (defun debbugs-gnu-insert-changelog ()
   "Add a ChangeLog from a recently applied patch from a third party."
   (interactive)
 (defun debbugs-gnu-insert-changelog ()
   "Add a ChangeLog from a recently applied patch from a third party."
   (interactive)

-  (let (from subject)
+  (let (from subject patch-subject changelog)

     (gnus-with-article-buffer
       (widen)
       (goto-char (point-min))
       (setq from (mail-extract-address-components (gnus-fetch-field "from"))
     (gnus-with-article-buffer
       (widen)
       (goto-char (point-min))
       (setq from (mail-extract-address-components (gnus-fetch-field "from"))

-           subject (gnus-fetch-field "subject")))
+           subject (gnus-fetch-field "subject"))
+      ;; If it's a patch formatted the right way, extract that data.
+      (dolist (handle (mapcar 'cdr (gnus-article-mime-handles)))
+       (when (string-match "diff\\|patch\\|plain"
+                           (mm-handle-media-type handle))
+         (with-temp-buffer
+           (insert-buffer-substring (mm-handle-buffer handle))
+           (cond ((eq (mm-handle-encoding handle) 'base64)
+                  (base64-decode-region (point-min) (point-max)))
+                 ((eq (mm-handle-encoding handle) 'quoted-printable)
+                  (quoted-printable-decode-region (point-min) (point-max))))
+           (setq patch-subject
+                 (or (gnus-fetch-field "subject") patch-subject))
+           (goto-char (point-min))
+           (when (re-search-forward "^[*] " nil t)
+             (let ((start (match-beginning 0)))
+               (while (and (not (eobp))
+                           (not (looking-at "---")))
+                 (forward-line 1))
+               (setq changelog (buffer-substring
+                                start (line-end-position 0)))))))))

     (let ((add-log-full-name (car from))
          (add-log-mailing-address (cadr from)))
       (add-change-log-entry-other-window)
     (let ((add-log-full-name (car from))
          (add-log-mailing-address (cadr from)))
       (add-change-log-entry-other-window)

+      (when patch-subject
+       (setq-local debbugs-gnu-patch-subject patch-subject))
+      (when changelog
+       (delete-region (line-beginning-position) (point-max))
+       (save-restriction
+         (narrow-to-region (point) (point))
+         (insert changelog)
+         (indent-region (point-min) (point-max))))

       (let ((point (point)))
        (when (string-match "\\(bug#[0-9]+\\)" subject)
          (insert " (" (match-string 1 subject) ")."))
       (let ((point (point)))
        (when (string-match "\\(bug#[0-9]+\\)" subject)
          (insert " (" (match-string 1 subject) ")."))


@@ -1583,7 +1647,9 @@ If given a prefix, patch in the branch directory instead."
                          (cadr from))))))
          (goto-char (point-max))
          (end-of-line)
                          (cadr from))))))
          (goto-char (point-max))
          (end-of-line)

-         (insert "  (tiny change"))
+         (when changelog
+           (insert "\n\n"))
+         (insert "  Copyright-paperwork-exempt: yes"))

        (goto-char point)))))
 
 (defvar debbugs-gnu-lisp-mode-map
        (goto-char point)))))
 
 (defvar debbugs-gnu-lisp-mode-map


@@ -1626,28 +1692,45 @@ If given a prefix, patch in the branch directory instead."
   "Prepare checking in the current changes."
   (interactive)
   (save-some-buffers t)
   "Prepare checking in the current changes."
   (interactive)
   (save-some-buffers t)

-   (when (get-buffer "*vc-dir*")
-     (kill-buffer (get-buffer "*vc-dir*")))
-   (let ((trunk (expand-file-name debbugs-gnu-trunk-directory)))
-     (if (equal (cl-subseq default-directory 0 (length trunk))
-               trunk)
-        (vc-dir debbugs-gnu-trunk-directory)
-       (vc-dir debbugs-gnu-branch-directory)))
-   (goto-char (point-min))
-   (while (not (search-forward "edited" nil t))
-     (sit-for 0.01))
-   (beginning-of-line)
-   (while (search-forward "edited" nil t)
-     (vc-dir-mark)
-     (beginning-of-line))
-   (vc-diff nil)
-   (vc-next-action nil)
-   (log-edit-insert-changelog t)
-   (delete-other-windows)
-   (split-window)
-   (other-window 1)
-   (switch-to-buffer "*vc-diff*")
-   (other-window 1))
+  (when (get-buffer "*vc-dir*")
+    (kill-buffer (get-buffer "*vc-dir*")))
+  (let ((patch-subject debbugs-gnu-patch-subject))
+    (let ((trunk (expand-file-name debbugs-gnu-trunk-directory)))
+      (if (equal (cl-subseq default-directory 0 (length trunk))
+                trunk)
+         (vc-dir debbugs-gnu-trunk-directory)
+       (vc-dir debbugs-gnu-branch-directory)))
+    (goto-char (point-min))
+    (while (not (search-forward "edited" nil t))
+      (sit-for 0.01))
+    (beginning-of-line)
+    (while (search-forward "edited" nil t)
+      (vc-dir-mark)
+      (beginning-of-line))
+    (vc-diff nil)
+    (vc-next-action nil)
+    (delete-region (point-min) (point-max))
+    (log-edit-insert-changelog t)
+    (delete-other-windows)
+    (split-window)
+    (other-window 1)
+    (switch-to-buffer "*vc-diff*")
+    (other-window 1)
+    (when patch-subject
+      (insert "Summary: "
+             (replace-regexp-in-string "^ *\\[PATCH\\] *" "" patch-subject)
+             "\n"))))
+
+(defun debbugs-gnu-save-cache ()
+  "Save the bugs cache to a file."
+  (interactive)
+  (unless debbugs-cache-data
+    (error "No data to cache"))
+  (unless (file-exists-p "~/.emacs.d/debbugs-cache")
+    (make-directory "~/.emacs.d/debbugs-cache" t))
+  (let ((coding-system-for-write 'utf-8))
+    (with-temp-file "~/.emacs.d/debbugs-cache/list"
+      (prin1 debbugs-cache-data (current-buffer)))))

 
 (provide 'debbugs-gnu)
 
 
 (provide 'debbugs-gnu)